;; $Id: //info.ravenbrook.com/user/ndl/lisp/bcs/etc/examples.lisp#6 $

(in-package "CL-USER")

;;                          EXAMPLES.LISP
;;           Nick Levine, Ravenbrook Limited, 2006-05-03
;; 
;; These are the examples I expect to use for my talk to BCS:SPA on
;; 2006-05-10.
;; 
;; This document is mainly for my operational convenience. Not a lot
;; useful will happen if you try to cl:load this document into a lisp
;; image.
;;
;; This document is provided "as is", without any express or implied
;; warranty.  In no event will the author be held liable for any
;; damages arising from the use of this document.  You may make and
;; distribute verbatim copies of this document provided that you do
;; not charge a fee for this document or for its distribution.

(test-progress-bar)

3

(+ 1 2)

(+ 1 2 3)

(+ (* 2 3) (* 4 5 6))

(+ (* 2 3) (* 4 (- 7 2) 6))

(list (* 2 3) (* 4 5 6))

(identity (+ (* 2 3) (* 4 5 6)))

;; (quote (+ (* 2 3) (* 4 5 6)))

'(+ (* 2 3) (* 4 5 6))

(list "my" (+ 1 2) 'sons) 

(setf them (list "my"  (+ 1 2) 'sons))

them

(listp them)

(listp (second them))

(second them)

(rest them)

(cons "your" (rest them))

(defun assemble (whose how-many what)
  (list whose how-many what))

(assemble "my"  (+ 1 2) 'sons)

(defun quadratic-solve (a b c)
  (let ((discriminant (- (* b b) (* 4 a c))))
    (if (< discriminant 0)
        (error "Discriminant was negative.")
      (let ((square-root (sqrt discriminant))
            (denominator (* -2 a)))
        (list (/ (+ b square-root) denominator)
              (/ (- b square-root) denominator))))))

(quadratic-solve 1 -5 6)

(quadratic-solve 1 0 1)

(lambda (a b c)
  (let ((discriminant (- (* b b) (* 4 a c))))
    (if (< discriminant 0)
        (error "Discriminant was negative.")
      (let ((square-root (sqrt discriminant))
            (denominator (* -2 a)))
        (list (/ (+ b square-root) denominator)
              (/ (- b square-root) denominator))))))

(setf quadratic-solver *)

(funcall quadratic-solver 1 4 4)

(defun factorial (x)
  (if (zerop x)
      1
    (* x (factorial (- x 1)))))

(factorial 6)

(setf my-function
      (lambda (x)
        (if (zerop x)
            1
          (* x (funcall my-function (- x 1))))))

(funcall my-function 6)

(lambda (x) (+ x 1))

(defun add-one ()
  (lambda (x) (+ x 1)))

(defun add-n (n)
  (lambda (x) (+ x n)))

(setf add-9 (add-n 9))

(funcall add-9 13)

(setf my-list ())

my-list

(push 'this my-list)

my-list

(push 'that my-list)

my-list

(pop my-list)

my-list

(pop my-list)

my-list

(defmacro my-push (thing place)
  (list 'setf place
        (list 'cons thing place)))

(macroexpand-1 '(my-push 'this my-list))

(my-push 'this my-list)

(defmacro my-push (thing place)
  `(setf ,place (cons ,thing ,place)))

(macroexpand-1 '(my-push 'that my-list))

(my-push 'that my-list)

(defmacro my-pop (place)
  `(let ((result (first ,place)))
    (setf ,place (rest ,place))
    result))

(macroexpand-1 '(my-pop my-list))

(my-pop my-list)

(my-pop my-list)

my-list


(test-progress-bar)

(make-and-display-progress-bar "Hello, world")

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (setf (progress-bar-value progress-bar) 0.7)
  progress-bar)

(window-still-alive *)

(destroy-window **)

(window-still-alive ***)

(dotimes (i 50)
  (princ "."))

(dotimes (i 50)
  (sleep 0.1)
  (princ "."))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (dotimes (i 50)
    (sleep 0.1)
    (setf (progress-bar-value progress-bar) (/ i 50))))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (dotimes (i 50)
    (sleep 0.1)
    (funcall (lambda (new-value progress-bar)
               (setf (progress-bar-value progress-bar) new-value))
             (/ i 50)
             progress-bar)))

(with-progress-bar "Hello, world"
                   (dotimes (i 50)
                     (sleep 0.1)
                     (funcall progress-fun (/ i 50) progress-bar)))

(defmacro with-progress-bar (title form)
  `(let ((progress-bar (make-and-display-progress-bar ,title))
         (progress-fun (lambda (new-value progress-bar)
                         (setf (progress-bar-value progress-bar) new-value))))
     ,form))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world"
                          (dotimes (i 50)
                            (sleep 0.1)
                            (funcall progress-fun (/ i 50) progress-bar)))))

(with-progress-bar "Hello, world"
                   (dotimes (i 50)
                     (sleep 0.1)
                     (funcall progress-fun (/ i 50) progress-bar)))

(with-progress-bar "Hello, world" progress-bar progress-fun
  (dotimes (i 50)
    (sleep 0.1)
    (funcall progress-fun (/ i 50) progress-bar)))

(defmacro with-progress-bar (title bar-var function-var form)
  `(let ((,bar-var (make-and-display-progress-bar ,title))
         (,function-var (lambda (new-value progress-bar)
                           (setf (progress-bar-value progress-bar) new-value))))
     ,form))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world" progress-bar progress-fun
                          (dotimes (i 50)
                            (sleep 0.1)
                            (funcall progress-fun (/ i 50) progress-bar)))))

(defmacro with-progress-bar (title bar-var function-var form)
  `(let* ((,bar-var (make-and-display-progress-bar ,title))
          (,function-var (lambda (new-value)
                           (setf (progress-bar-value ,bar-var) new-value))))
     ,form))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world" progress-bar progress-fun
                          (dotimes (i 50)
                            (sleep 0.1)
                            (funcall progress-fun (/ i 50))))))

(with-progress-bar "Hello, world" progress-fun
  (dotimes (i 50)
    (sleep 0.1)
    (funcall progress-fun (/ i 50))))

(gensym)

(gensym "PROGRESS")

(defmacro with-progress-bar (title function-var form)
  (let ((bar-var (gensym "PROGRESS-BAR-")))
    `(let* ((,bar-var (make-and-display-progress-bar ,title))
            (,function-var (lambda (new-value)
                             (setf (progress-bar-value ,bar-var) new-value))))
       ,form)))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world" progress-fun
                          (dotimes (i 50)
                            (sleep 0.1)
                            (funcall progress-fun (/ i 50))))))

(with-progress-bar "Hello, world" progress-fun
  (dotimes (i 50)
    (sleep 0.1)
    (funcall progress-fun (/ i 50))))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (dotimes (i 50)
    (sleep 0.1)
    (setf (progress-bar-value progress-bar) (/ i 50))))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (dotimes (i 50)
    (sleep 0.1)
    (if (window-still-alive progress-bar)
        (setf (progress-bar-value progress-bar) (/ i 50))
      (return))))

(defmacro with-progress-bar (title function-var form)
  (let ((bar-var (gensym "PROGRESS-BAR-")))
    `(let* ((,bar-var (make-and-display-progress-bar ,title))
            (,function-var (lambda (new-value)
                             (if (window-still-alive ,bar-var)
                                 (setf (progress-bar-value ,bar-var) new-value)
                               nil))))
       ,form)))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world" progress-fun
                          (dotimes (i 50)
                            (sleep 0.1)
                            (if (funcall progress-fun (/ i 50))
                                nil
                              (return))))))

(with-progress-bar "Hello, world" progress-fun
  (dotimes (i 50)
    (sleep 0.1)
    (if (funcall progress-fun (/ i 50))
        nil
      (return))))

(defmacro with-progress-bar (title function-var form)
  (let ((bar-var (gensym "PROGRESS-BAR-")))
    `(let* ((,bar-var (make-and-display-progress-bar ,title))
            (,function-var (lambda (new-value)
                             (when (window-still-alive ,bar-var)
                               (setf (progress-bar-value ,bar-var) new-value)))))
       ,form)))

(with-progress-bar "Hello, world" progress-fun
                   (dotimes (i 50)
                     (sleep 0.1)
                     (unless (funcall progress-fun (/ i 50))
                       (return))))

(pprint (macroexpand-1 '(with-progress-bar "Hello, world" progress-fun
                          (dotimes (i 50)
                            (sleep 0.1)
                            (unless (funcall progress-fun (/ i 50))
                              (return))))))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (dotimes (i 50)
    (sleep 0.1)
    (if (window-still-alive progress-bar)
        (setf (progress-bar-value progress-bar) (/ i 50))
      (return)))
  (destroy-window progress-bar))

(let ((progress-bar (make-and-display-progress-bar "Hello, world")))
  (unwind-protect
      (dotimes (i 50)
        (sleep 0.1)
        (if (window-still-alive progress-bar)
            (setf (progress-bar-value progress-bar) (/ i 50))
          (return)))
    (destroy-window progress-bar)))

(defmacro with-progress-bar (title function-var form)
  (let ((bar-var (gensym "PROGRESS-BAR-")))
    `(let* ((,bar-var (make-and-display-progress-bar ,title))
            (,function-var (lambda (new-value)
                             (when (window-still-alive ,bar-var)
                               (setf (progress-bar-value ,bar-var) new-value)))))
       (unwind-protect
           ,form
         (destroy-window ,bar-var)))))

(with-progress-bar "Hello, world" progress-fun
                   (dotimes (i 50)
                     (sleep 0.1)
                     (unless (funcall progress-fun (/ i 50))
                       (return))))

(defmacro with-progress-bar ((title function-var) &body forms)
  (let ((bar-var (gensym "PROGRESS-BAR-")))
    `(let* ((,bar-var (make-and-display-progress-bar ,title))
            (,function-var (lambda (new-value)
                             (when (window-still-alive ,bar-var)
                               (setf (progress-bar-value ,bar-var) new-value)))))
       (unwind-protect
           (progn ,@forms)
         (destroy-window ,bar-var)))))

(with-progress-bar ("Hello, world" progress-fun)
  (dotimes (i 50)
    (sleep 0.1)
    (unless (funcall progress-fun (/ i 50))
      (return))))

(pprint (macroexpand-1 '(with-progress-bar ("Hello, world" progress-fun)
                          (dotimes (i 50)
                            (sleep 0.1)
                            (unless (funcall progress-fun (/ i 50))
                              (return))))))

(pprint (walker:walk-form '(with-progress-bar ("Hello, world" progress-fun)
                             (dotimes (i 50)
                               (sleep 0.1)
                               (unless (funcall progress-fun (/ i 50))
                                 (return))))))


(defun test-xhtml (title)
  (with-xhtml (stream)
    (let ((capitalized-title (string-capitalize title)))
      (head (title capitalized-title))
      (body (h1 capitalized-title)
            (ul (li (p (format stream "It was the best of ~a, it was the worst of ~a."
                               title title))))))))

(test-xhtml "times")

(setf *all-tags*
      '(a abbr acronym address applet area b base basefont bdo big
          blockquote body br button caption center cite code col colgroup
          dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6
          head hr html i iframe img input ins isindex kbd label legend li
          link map menu meta noframes noscript object ol optgroup option p
          param pre q s samp script select small span strike strong style
          sub sup table tbody td textarea tfoot th thead title tr tt u ul
          var))

(defun form-write-tags (form stream)
  (or (when (listp form)
        (let ((first (first form)))
          (when (find first *all-tags*)
            (let ((tag (string-downcase first)))
              `(progn
                 (format ,stream "<~a>" ,tag)
                 ,@(rest form)
                 (format ,stream "</~a>~%" ,tag))))))
      form))

(form-write-tags '(p (format stream "It was the best of ~a, it was the worst of ~a."
                             title title))
                 'stream)

(defmacro with-xhtml ((stream) form)
  (form-write-tags form stream))

(pprint (macroexpand-1 '(with-xhtml (stream)
                          (p (format stream "It was the best of ~a, it was the worst of ~a."
                                     title title)))))

(defun form-write-tags (form stream)
  (or (when (listp form)
        (let ((first (first form)))
          (when (find first *all-tags*)
            (let ((tag (string-downcase first)))
              `(progn
                 (format ,stream ,(format nil "<~a>" tag))
                 ,@(rest form)
                 (format ,stream ,(format nil "</~a>~%" tag)))))))
      form))

(pprint (macroexpand-1 '(with-xhtml (stream)
                          (p (format stream "It was the best of ~a, it was the worst of ~a."
                                     title title)))))

(pprint (macroexpand-1 '(with-xhtml (stream)
                          (title capitalized-title))))

(defun form-write-tags (form stream)
  (or (when (listp form)
        (let ((first (first form)))
          (when (find first *all-tags*)
            (let ((tag (string-downcase first)))
              `(progn
                 (format ,stream ,(format nil "<~a>" tag))
                 ,@(collect-subforms (rest form) stream)
                 (format ,stream ,(format nil "</~a>~%" tag)))))))
      form))

(defun collect-subforms (subforms stream)
  (when subforms
    (cons (let ((content (first subforms)))
            (if (listp content)
                content
              `(format ,stream "~a" ,content)))
          (collect-subforms (rest subforms) stream))))

(pprint (macroexpand-1
         '(with-xhtml (stream)
                      (title capitalized-title))))

(pprint (macroexpand-1
         '(with-xhtml (stream)
                      (head (title capitalized-title)))))

(defun collect-subforms (subforms stream)
  (when subforms
    (cons (let ((content (first subforms)))
            (if (listp content)
                (form-write-tags content stream)
              `(format ,stream "~a" ,content)))
          (collect-subforms (rest subforms) stream))))

(pprint (macroexpand-1
         '(with-xhtml (stream)
            (body (h1 capitalized-title)
                  (ul (li (p (format stream "It was the best of ~a, it was the worst of ~a."
                                     title title))))))))

(pprint (macroexpand-1
         '(with-xhtml (stream)
            (let ((capitalized-title (string-capitalize title)))
              (head (title capitalized-title))
              (body (h1 capitalized-title)
                    (ul (li (p (format stream "It was the best of ~a, it was the worst of ~a."
                                       title title)))))))))

(defun form-write-tags (form stream)
  (or (when (listp form)
        (let ((first (first form)))
          (when (find first *all-tags*)
            (let ((tag (string-downcase first)))
              `(progn
                 (format ,stream ,(format nil "<~a>" tag))
                 ,@(collect-subforms (rest form) stream)
                 (format ,stream ,(format nil "</~a>~%" tag)))))))
      form))

(defun collect-subforms (subforms stream)
  (when subforms
    (cons (let ((content (first subforms)))
            (if (listp content)
                content
              `(format ,stream "~a" ,content)))
          (collect-subforms (rest subforms) stream))))

(defmacro with-xhtml ((stream) &body body)
  (let ((walked-body (walk-form `(html ,@body)
                                (lambda (subform)
                                  (form-write-tags subform stream)))))
    `(with-output-to-string (,stream)
       ,walked-body)))

(defun walk-form (form walker)
  (walker:walk-form form ()
                    (lambda (form &rest ignore)
                      (declare (ignore ignore))
                      (funcall walker form))))

(pprint (macroexpand-1
         '(with-xhtml (stream)
            (let ((capitalized-title (string-capitalize title)))
              (head (title capitalized-title))
              (body (h1 capitalized-title)
                    (ul (li (p (format stream "It was the best of ~a, it was the worst of ~a."
                                       title title)))))))))