;;;;;;;; Problem 1. ;;;;;;;;;

;; This code replies heavily on the accumulator trick described in OnLisp
;;  (see, e.g., "flatten" in OnLisp (Fig. 4.3, PDF page 62, code at
;;    http://ep.yimg.com/ty/cdn/paulgraham/onlisp.lisp)

;; Such code works for any lists, not just the tree represenations I described.
;;  There's nothing special about my tree represenations---in fact, it's by
;;  far not the most economical, just easier (for me) to visualize.

;; sum up number nodes
(defun tree-sum-numbers (tree)
  (labels ((tsum (node acc)              ; acc holds the sum
             (cond ((null node) acc)                       ; nothing to do on this node
                   ((atom node)                            ; no more subtrees, just the value at a leaf
                    (if (numberp node) (+ node acc) acc))
                   (t (tsum (car node)                      ; it's cons cell, continue down
                           (tsum (cdr node) acc))))))       ;     and to the right
    (tsum tree 0)))

;; test base cases first!
(tree-sum-numbers nil)
(tree-sum-numbers '(10))

;; then test some more:
(tree-sum-numbers '(0 (2 (3 (5)) (7) (4 (5))) (a (b (c)) (d) (e (f)))))
(tree-sum-numbers '(5 (1 (2))))

;;  Note: this function will work for any lists, not just the
;;   kinds of tree representations I described, e.g.:
(tree-sum-numbers '(1 2 3))

;; depth-first traversal, calling testfunc on each node, adding to the list if true
(defun tree-filter-nodes (tree testfunc)
  (labels ((tfm (node acc)                     ; acc catches the result list
             (cond
               ((null node) acc)
               ((atom node)
                (if (funcall testfunc node)
                    (cons node acc)
                    acc))
               (t (tfm (car node)              ; this evaluates first, so we get DFT
                       (tfm (cdr node) acc))))))
    (tfm tree ())))

;; list of all numbers:
(tree-filter-nodes '(0 (2 (3 (5)) (7) (4 (5))) (a (b (c)) (d) (e (f))))
                   (lambda (x) (numberp x)))

;; list of all strings
(tree-filter-nodes '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f"))))
                   (lambda (x) (stringp x)))

;; we can give them names, too:
(defun tree-filter-numbers (tree)
  (tree-filter-nodes tree  (lambda (x) (numberp x))))

;; or even shorter:
(defun tree-filter-numbers (tree)
  (tree-filter-nodes tree  #'numberp))

;; also
(defun tree-filter-strings (tree)
  (tree-filter-nodes tree  #'stringp))

(tree-filter-strings '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))

;; copy a tree, applying a processing function to leaf values
;;   note that this is written without an accumulator, and is _not_ tail-recursive
(defun dft-copy (node func)
  (cond ((null node) nil)
        ((atom node) (funcall func node))       ; at leaf, apply func
        (t (cons (dft-copy (car node) func)      ; make a new cons cell
                 (dft-copy (cdr node) func)))))

(dft-copy nil (lambda (x) x))
(dft-copy '(1) (lambda (x) x))
(dft-copy '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f"))))
          (lambda (x) x))

;; now make func convert strings to symbols, non-destructively
(defun tree-convert-strings-to-symbols (tree)
  (dft-copy tree
            (lambda (a)
              (if (stringp a) (intern a)
                  a))))

;; expect to see some strangeness here: depending on your lisp, newly created symbols
;;   may be printed with clues that you just interned them.
;; Make-symbol is another possibility here, to make _uninterned_ symbols (i.e., package-less,
;;   not included in the current package).
(tree-convert-strings-to-symbols '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))

;; destructive version, also recursive. Note: its return value is not very useful.
(defun tree-convert-strings-to-symbols-destructive (node)
  (cond ((null node) node)
        ((atom node) node)            ; we should only hit this if given a dotted pair, which we don't expect
                                      ;   so just leave it alone
        ((and (consp node)
              (stringp (car node)))
         (progn
           (rplaca node (intern (car node)))
           (tree-convert-strings-to-symbols-destructive (cdr node))))
        (t (progn
             (tree-convert-strings-to-symbols-destructive (car node))
             (tree-convert-strings-to-symbols-destructive (cdr node))))))


(setq l '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))

(tree-convert-strings-to-symbols-destructive l)
l
(tree-convert-strings-to-symbols-destructive '("foo"))

;; We could make the return value be the changed tree, just like nconc & friends
(defun tree-convert-strings-to-symbols-destructive (tree)
  (labels ((tcsd (node)
             (cond ((null node) node)
                   ((atom node) node)
                   ((and (consp node)
                         (stringp (car node)))
                    (progn
                      (rplaca node (intern (car node)))
                      (tcsd (cdr node))))
                   (t (progn
                        (tcsd (car node))
                        (tcsd (cdr node)))))))
    (progn (tcsd tree)
           tree)))

(setq l '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))
(tree-convert-strings-to-symbols-destructive l)

;; reordered tree: numbers < strings < symbols at each level
;;   This is actually the first place where my interpretation of what
;;   it means for a list to represent a tree comes into play---because
;;   we need to agree which nodes are on the same level. Same for
;;   breadth-first traversal (BFT).

;; Let's define a few helper functions

(defun leafp (node)
  "The argument is a list of exactly one element, which is an atom"
  (and (consp node)
       (null (cdr node))
       (atom (car node))))

;; Let's try first for a function that orders just one level of the tree.

;; Note: this one is non-destructive, and non-tail-recursive.  Since
;;  Common Lisp's sort for lists _is_ destructive on the lists passed
;;  to it, we make a copy of the level first.

(defun tree-reorder-level (node)
  "Sort one level of a tree in the order number < string < symbol"
  (cond ((null node) node)
        ((atom node) node)  ; nothing to reorder
        ((leafp node) node)
        (t                  ; this is list, and it must be sorted
         (let* ((branches (cdr node))      ; the car is the value at node, the cdr is the list of child subtrees
                (lev (copy-seq branches)))  ; sort the subtrees on the value types of their cars
           (sort lev
                 (lambda (subtree1 subtree2)  ; when should subtree1 precede subtree2?
                   (let ((c1 (car subtree1))  ;   this predicate is a "strict less", F if order need not be reversed
                         (c2 (car subtree2)))
                     (cond ((and (numberp c1)
                                 (not (numberp c2))) t) ; either string or symbol (if the tree is valid)
                           ((and (stringp c1)
                                 (symbolp c2)) t)       ; only symbols beats a string
                           (t nil)))))                 ; false otherwise
           (cons (car node) lev)))))

(tree-reorder-level nil)
(tree-reorder-level '(1))
(tree-reorder-level '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))
(tree-reorder-level '(0 (a (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))
(tree-reorder-level '(0 (b (3 (5)) (7) (4 ("5"))) (a  (b (c)) (d) (e ("f")))))
(tree-reorder-level '(0 (a (3 (5)) (7) (4 ("5"))) (a  (b (c)) (d) (e ("f")))))
(tree-reorder-level '(0 (a (3 (5)) (7) (4 ("5"))) (10  (b (c)) (d) (e ("f")))))

;; Finally, the full function. Turns out it's not all that different
;;  from the one-level solution---it just needs to apply recursively
;;  to every branch/subtree under a node before these branches are
;;  sorted. I should've seen it right away, but in fact I didn't. So
;;  it goes: solve a smaller, one-off problem first, and then the
;;  solution to the larger recursive one manifests itself.

;;; In this one, we actually don't need copy-seq, because mapcar will create
;;;  it own copy.

(defun tree-reorder (node)
  "Sort each level of a tree in the order number < string < symbol"
  (cond ((null node) node)
        ((atom node) node)  ; nothing to reorder
        ((leafp node) node)
        (t                  ; this is list, and it must be sorted
         (let ((branches (mapcar #'tree-reorder (cdr node))))
           (sort branches
                 (lambda (subtree1 subtree2)  ; the same "strict less" predicate
                   (let ((c1 (car subtree1))
                         (c2 (car subtree2)))
                     (cond ((and (numberp c1)
                                 (not (numberp c2))) t) ; either string or symbol (if the tree is valid)
                           ((and (stringp c1)
                                 (symbolp c2)) t)       ; only symbols beats a string
                           (t nil)))))                 ; false otherwise
           (cons (car node) branches)))))

;; Some tests:
(tree-reorder nil)
(tree-reorder '(1))
(tree-reorder '(0 (2 (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))
(tree-reorder '(0 (a (3 (5)) (7) (4 ("5"))) ("a" (b (c)) (d) (e ("f")))))
(tree-reorder '(0 (b (3 (5)) (7) (4 ("5"))) (a  (b (c)) (d) (e ("f")))))
(tree-reorder '(0 (a (3 (5)) (7) (4 ("5"))) (a  (b (c)) (d) (e ("f")))))
(tree-reorder '(0 (a (3 (5)) (7) (4 ("5"))) (10  (b (c)) (d) (e ("f")))))

(tree-reorder '(0 (a (foo (5)) (7) ("4" ("5")))))
(tree-reorder '(0 (a (foo (5)) (7) ("4" ("5"))) (10  (b (c)) ("str") (3 ("f")))))

;; Breadth-first traversal

;; Recursive traversal is "depth-first". So we need an extra data
;;    structure---a queue---to convert a DFT to BFT.
;; This is tail-recursive; in C, it would be written as a while loop,
;;    and a good Lisp compiler that does TCO will compile it as such.

;; Note: in our representation of trees, for any node:
;;    (car node) gives the value at that node (whether it's a leaf or not),
;;    (cdr node) gives the list of subtrees under that node, nil if none.

(defun tree-breadth-first-list (tree)  ; apply func to each leaf, return the list of results
  (let ((q (list tree)))         ; this is our queue, we'll operate on it destructively with pop and nconc
    (labels ((bft (q acc)
               (if (null q) acc  ; queue is empty, we are done
                   ; otherwise
                   (let* ((node (pop q))
                          (subtrees (cdr node)))
                     (bft (nconc q subtrees) (cons (car node) acc))))))
      (nreverse (bft q ())))))

(tree-breadth-first-list nil)
(tree-breadth-first-list '(0))
(tree-breadth-first-list '(0 (1 (a (b) (c))) (2 (d))))
(tree-breadth-first-list '(0 (a (foo (5)) (7) ("4" ("5"))) (10  (b (c)) ("str") (3 ("f")))))

;;;;;;;;;;;;;; Problem 2 ;;;;;;;;;;;;;;;

;; There are many solutions of this on the Internet, googlable
;; by "tail-recursive" and "fibonacci". The trick is, as before,
;; passing the values you need down to the recursive function.

(defun fibonacci-tr (n)
  (labels ((fib-tr (n a b)
             (if (< n 2) a
                 (fib-tr (- n 1) b (+ a b)))))
    (fib-tr n 1 1)))

(fibonacci-tr 1)
(fibonacci-tr 2)
(fibonacci-tr 9)
(fibonacci-tr 10)
(fibonacci-tr 14)

;; You can draw the spiral using the Lisp-Tk kit LTK, available
;;  via the Quicklisp package system. I tested it on Yosemite.

;;;;;;;;;;;;;; Problem 3 ;;;;;;;;;;;;;;;

;; This problem is also a textbook example of closures.

;; first, without optional values
(defun make-counter ()
  (let ((state 0)
        (step  1))
    (list
     (lambda () state)                           ; value
     (lambda () (setq state (+ state step)))     ; inc
     (lambda () (setq state (- state step))))))  ; dec

(setq cnt1 (make-counter))
(funcall (nth 0 cnt1))
(funcall (nth 1 cnt1))
(funcall (nth 1 cnt1))
(funcall (nth 1 cnt1))
(funcall (nth 0 cnt1))
(funcall (nth 2 cnt1))
(funcall (nth 0 cnt1))

(setq cnt1-val (nth 0 cnt1))
(setq cnt1-inc (nth 1 cnt1))
(setq cnt1-dec (nth 2 cnt1))

(funcall cnt1-val)
(funcall cnt1-inc)
(funcall cnt1-dec)

;; or, for better style, you could write a macro that creates
;;   and assigns names to the returned lambdas. CLOS does autocreate
;;   macros for accessor functions of an object.

;; With optional parameters (nil if not given)
(defun make-counter (&optional v i)
  (let ((state (if (null v) 0 v))
        (step  (if (null i) 1 i)))
    (list
     (lambda () state)                           ; value
     (lambda () (setq state (+ state step)))     ; inc
     (lambda () (setq state (- state step))))))  ; dec

(setq cnt2 (make-counter 10))
(setq cnt2-val (nth 0 cnt2)
      cnt2-inc (nth 1 cnt2)
      cnt2-dec (nth 2 cnt2))

(funcall cnt2-val)
(funcall cnt2-dec)
(funcall cnt2-dec)
(funcall cnt2-dec)
(funcall cnt2-val)

;;;;;;;;;;;;;;; Problem 4 ;;;;;;;;;;;;;;;;

;; To automate testing
#||
------------------- pasted from shell ----------------------
$ cat expr2sexp.rb
require 'ripper'
require 'pp'
code = ARGV.shift
puts Ripper.sexp(code).pretty_inspect.tr("[],\n", "()  ")

$ ruby expr2sexp.rb  "2+2 * 3"
(:program   ((:binary     (:@int  "2"  (1  0))     :+     (:binary  (:@int  "2"  (1  2))  :*  (:@int  "3"  (1  6))))))

$ ruby expr2sexp.rb "2+2 * 3" > ex1.sexp
------------------------------------------------------------
||#

;; You will find a slightly better version of expr2sexp.rb in warmup/ . It removes
;;  unnecessary extra spaces between the list elements.

;; to get the list from the file
(with-open-file (f "ex1.sexp")
  (setq line (read f)))

;; So line is already a list with appropriate symbols and values
(car line)    ; :PROGRAM
(cdr line)    ; (((:BINARY (:@INT "2" (1 0)) :+
              ;    (:BINARY (:@INT "2" (1 2)) :* (:@INT "3" (1 6))))))
(caadr line)  ; (:BINARY (:@INT "2" (1 0)) :+
              ;  (:BINARY (:@INT "2" (1 2)) :* (:@INT "3" (1 6))))))

(caaadr line) ; :BINARY

;; So now to write a recursive evaluator for such lists. Observe 
;;  that each node starts with a tag (:program, :binary, :@int) then contains some
;;  values or subtrees. We can deside what to do with a node based on the tag.     

(defun ruby-arithm-eval (exp)
  (cond ((null exp) nil)  ; what's the evaluation of an empty list?
        ((atom exp) exp)  ; there should not be any bareword values fed to us; ints are made with :@int!
                          ;   but, we can just return whatever it was
        (t                ; main case: it's a list/node 
         (let ((tag  (car exp))
               (args (cdr exp)))
           (cond ((eql tag :program) (ruby-arithm-eval (caar args)))  ; remove extra level of list, pass down
                 ((eql tag :binary)  ; get the operator and a proper list of arguments
                  (let ((op (nth 1 args))
                        (arg1 (nth 0 args))
                        (arg2 (nth 2 args)))
                    (do-op op (ruby-arithm-eval arg1) (ruby-arithm-eval arg2))))
                 ((eql tag :@int) (parse-integer (nth 0 args)))
                 (t                  ; unknown tag, signal error
                  (error "Unknown tag ~s" tag)))))))

(defun do-op (op x y)
  (cond ((eql op :+) (+ x y))
        ((eql op :*) (* x y))
        ((eql op :-) (- x y))
        ((eql op :/) (/ x y))
        (t 
         (error "Unknown op ~s" op))))

;; test from the ground up
(do-op :+ 2 3)
(do-op :* 2 3)
(do-op :% 2 3)

(ruby-arithm-eval line)   ; 8, yay

;; $ ruby expr2sexp.rb "2+3+4+5" > ex2.sexp
(with-open-file (f "ex2.sexp")
  (ruby-arithm-eval (read f))) ; 14, yay 

;; We want a better way to test it. Unfortunately, the interface for calling
;;   on the system shell to run a program is not standard among LISPs.
;; I posted the how-to on this separately, in
;;   shell-commands-from-sbcl-howto.txt 

;;;;;;;;;;;;;;; Problem 5 ;;;;;;;;;;;;;;;;

;; A simple recursive traversal will do it. Using an accumulator
;;   because it's simpler and more natural here.

;; Note that we get two kinds of lists here: just lists of HTML elements
;;  and a list representing a tag, starting with a keyword. 

;; There's another weird wrinkle with this parser, though: it includes
;;  the text of the anchor _not_ in the A element, but encloses it 
;;  in a list headed by the :A tag. So we must match it accordingly:
;;  look for lists that have (:A ...) as their first element, and grab
;;  the rest. 

;; write this test first
(defun is-anchor (l)
  (cond ((and (consp l)
              (consp (car l))
              (eql (caar l) :a)))
        (t nil)))

(is-anchor nil)
(is-anchor '(:a ))
(is-anchor '((:a )))

;; Little operations can be messy, so write and debug them first.

;; href grabber -- assumes is-anchor is true on a
(defun grab-href (a)
  (let ((rest (cdr (member :href (car a)))))
    (if (null rest)
        "NO URL"
        (car rest))))

(grab-href '((:a )))
(grab-href '((:a :href)))
(grab-href '((:a :href "http://foo")))

;; grab the rest of the anchor's text -- assumes is-anchor is true on a
;;  flatten the text recursively
(defun grab-atext (a)
  (let ((text-subtree (cdr a)))
    (labels ((collect-strings (n acc)
               (cond ((null n) acc)
                     ((atom n) 
                      (if (stringp n) (concatenate 'string n acc) acc))
                     (t (collect-strings (car n)
                                         (collect-strings (cdr n) acc))))))
      (collect-strings text-subtree ""))))

(is-anchor '((:a :href "http://foo") "text"))
(cdr '((:a :href "http://foo") "text"))

(grab-atext '((:a :href "http://foo")))
(grab-atext '((:a :href "http://foo") "text"))
(grab-atext '((:a :href "http://foo") "text " (:I "foo" " " (:FOO "--")) (:b "bar")))

(defun pick-anchors (doc)
  (labels ((dft-a (elt acc)
             (cond ((null elt) acc)
                   ((atom elt) acc)    ; What should we do when given a string, not a list? 
                   ((is-anchor elt)    ; OK, this is a list containing (:A ...) as its first element
                    (let ((href (grab-href elt))
                          (text (grab-atext elt)))
                      (cons (list href text) acc)))  ; Importantly, we don't need to recurse here, as achnors should not nest 
                   (t                  ; Just recurse
                    (dft-a (car elt)
                           (dft-a (cdr elt) acc))))))
    (dft-a doc ())))
             
(pick-anchors '(((:A :HREF "http://www.quicklisp.org/") "QuickLisp " (:I "Beta"))))
;=> (("http://www.quicklisp.org/" "QuickLisp Beta"))

(pick-anchors '((:HEAD (:TITLE "My page"))
 (:BODY
   (:P "Nothing here but plain old 1990s "
      ((:A :HREF "http://www.w3schools.com/html/") "HTML")))))
;=> (("http://www.w3schools.com/html/" "HTML"))

;; testing with the saved output of cl-html-parse on the dev/examples/contancts.html file:
(with-open-file (out "p5-results.out" :direction :output :if-exists :overwrite :if-does-not-exist :create) 
  (with-open-file (s "p5-parsed-html-example.sexp")
    (write (pick-anchors (read s))
           :stream out)))

;; Notice how LISP handles reading and writing files. 
;;    The :direction  is either :input (default) or :output (you must specify it to write a file). 
;;    The keywords :if-exists and :if-does-not-exist are crucial, because otherwise LISP will 
;;      refuse to overwrite an existing file or create a non-existing one. 
;; These flags are somewhat similar to C's O_RDWR, O_CREAT, etc. for open(). 

;; I generated the p5-parsed-html-example.sexp from an SBCL prompt in a different buffer.
;; The transcript with comments is in p5-saving-parsed-html-howto.txt .