Added dependencies.

Pascal J. Bourguignon [2011-01-01 01:42]
Added dependencies.
Filename
compile-all.lisp
draw-tree.lisp
memoize.lisp
diff --git a/compile-all.lisp b/compile-all.lisp
new file mode 100644
index 0000000..6fac660
--- /dev/null
+++ b/compile-all.lisp
@@ -0,0 +1,57 @@
+#-(and)
+(map nil 'print
+     (sort (remove-if (lambda (p) (search "scratch" p))
+                      (mapcar (function file-namestring) (directory "p*.lisp")))
+           (function string<)))
+
+(dolist (src '("p01.lisp"
+               "p02.lisp"
+               "p03.lisp"
+               "p04.lisp"
+               "p05.lisp"
+               "p06.lisp"
+               "p07.lisp"
+               "p08.lisp"
+               "p09.lisp"
+               "p10.lisp"
+               "p11.lisp"
+               "p12.lisp"
+               "p13.lisp"
+               "p14.lisp"
+               "p15.lisp"
+               "p16.lisp"
+               "p17.lisp"
+               "p18.lisp"
+               "p19.lisp"
+               "p20.lisp"
+               "p21.lisp"
+               "p22.lisp"
+               "p23.lisp"
+               "p24.lisp"
+               "p25.lisp"
+               "p26.lisp"
+               "p27.lisp"
+               "p28.lisp"
+               "p31.lisp"
+               "p32.lisp"
+               "p33.lisp"
+               "p34.lisp"
+               "p35.lisp"
+               "p36.lisp"
+               "p37.lisp"
+               "p38.lisp"
+               "p39.lisp"
+               "p40.lisp"
+               "p41.lisp"
+               "p46.lisp"
+               "rdp.lisp"     "p47.lisp"
+               "p48.lisp"
+               "memoize.lisp" "p49.lisp"
+               "p50.lisp"
+               "p54a.lisp"
+               "p55.lisp"
+               "p56.lisp"
+               "p57.lisp"
+               "draw-tree.lisp" "p58.lisp"
+               ))
+  (load (compile-file src)))
diff --git a/draw-tree.lisp b/draw-tree.lisp
new file mode 100644
index 0000000..acc60ce
--- /dev/null
+++ b/draw-tree.lisp
@@ -0,0 +1,186 @@
+;;;; -*- coding:utf-8 -*-
+
+;; ─ ━ │ ┃ ┄ ┅ ┆ ┇ ┈ ┉ ┊ ┋ ┌ ┍ ┎ ┏ ┐ ┑ ┒ ┓ └ ┕ ┖ ┗ ┘ ┙ ┚ ┛ ├ ┝ ┞ ┟ ┠ ┡
+;; ┢ ┣ ┤ ┥ ┦ ┧ ┨ ┩ ┪ ┫ ┬ ┭ ┮ ┯ ┰ ┱ ┲ ┳ ┴ ┵ ┶ ┷ ┸ ┹ ┺ ┻ ┼ ┽ ┾ ┿ ╀ ╁ ╂ ╃
+;; ╄ ╅ ╆ ╇ ╈ ╉ ╊ ╋ ╌ ╍ ╎ ╏ ═ ║ ╒ ╓ ╔ ╕ ╖ ╗ ╘ ╙ ╚ ╛ ╜ ╝ ╞ ╟ ╠ ╡ ╢ ╣ ╤ ╥
+;; ╦ ╧ ╨ ╩ ╪ ╫ ╬ ╭ ╮ ╯ ╰ ╱ ╲ ╳ ╴ ╵ ╶ ╷ ╸ ╹ ╺ ╻ ╼ ╽ ╾ ╿
+
+(defparameter *unicode-box*
+  '(:TOP-LEFT     "╔"
+    :TOP-RIGHT    "╗"
+    :BOTTOM-LEFT  "╚"
+    :BOTTOM-RIGHT "╝"
+    :TOP          "═"
+    :BOTTOM       "═"
+    :LEFT         "║"
+    :RIGHT        "║"))
+
+(defparameter *unicode-line*
+  '(:TOP-LEFT     "┌"
+    :TOP-RIGHT    "┐"
+    :BOTTOM-LEFT  "└"
+    :BOTTOM-RIGHT "┘"
+    :horizontal   "─"
+    :vertical     "│"
+    :bottom-butt  "╧"
+    :top-butt     "╤"
+    :left-butt    "╟"
+    :right-butt   "╢"))
+
+
+(defparameter *ascii-box*
+  '(:TOP-LEFT     "+"
+    :TOP-RIGHT    "+"
+    :BOTTOM-LEFT  "+"
+    :BOTTOM-RIGHT "+"
+    :TOP          "-"
+    :BOTTOM       "-"
+    :LEFT         "|"
+    :RIGHT        "|"))
+
+(defparameter *ascii-line*
+  '(:TOP-LEFT     "+"
+    :TOP-RIGHT    "+"
+    :BOTTOM-LEFT  "+"
+    :BOTTOM-RIGHT "+"
+    :horizontal   "-"
+    :vertical     "|"
+    :bottom-butt  "-"
+    :top-butt     "-"
+    :left-butt    "|"
+    :right-butt   "|"))
+
+
+(defparameter *box*  *unicode-box*)
+(defparameter *line* *unicode-line*)
+
+
+(defstruct subtree-view
+  "
+
+          +---*
+          |
+    +-------+
+    * label |
+    +-------+
+          |
+          +---*
+
+The origin is the left of the label box.
+"
+  node
+  label                 ; the label string
+  label-box-width
+  vertical-height-above ; length of the vertical line above the origin.
+  vertical-height-below ; length of the vertical line below the origin.
+  width                 ; total width.
+  height-above          ; height above origin.
+  height-below          ; height below origin.
+  left-subtree-view
+  right-subtree-view)
+
+
+(defun subtree-view-height (subtree-view)
+  (+ 1 ; one more, for the label.
+     (subtree-view-height-above subtree-view)
+     (subtree-view-height-below subtree-view)))
+
+
+(defun binary-tree-to-view (tree)
+  (if (binary-tree-empty-p tree)
+      (make-subtree-view :node tree
+                         :label " nil"
+                         :label-box-width 4
+                         :vertical-height-above 0
+                         :vertical-height-below 0
+                         :width 4
+                         :height-above 0
+                         :height-below 0)
+     (let* ((label (princ-to-string (binary-tree-label tree)))
+            (view (make-subtree-view :node tree
+                                     :label label
+                                     :label-box-width (+ 4 (length label))
+                                     :right-subtree-view (binary-tree-to-view (binary-tree-right tree))
+                                     :left-subtree-view  (binary-tree-to-view (binary-tree-left  tree)))))
+       (setf (subtree-view-vertical-height-above view) (1+ (subtree-view-height-below (subtree-view-right-subtree-view view)))
+             (subtree-view-height-above view)          (1+ (subtree-view-height       (subtree-view-right-subtree-view view)))
+             (subtree-view-vertical-height-below view) (1+ (subtree-view-height-above (subtree-view-left-subtree-view view)))
+             (subtree-view-height-below view)          (1+ (subtree-view-height       (subtree-view-left-subtree-view view)))
+             (subtree-view-width view)                 (+ (subtree-view-label-box-width view)
+                                                          3
+                                                          (max (subtree-view-width (subtree-view-left-subtree-view view))
+                                                               (subtree-view-width (subtree-view-right-subtree-view view)))))
+       view)))
+
+
+#-(and) "
+
+
+        5                  ┌─── nil    2
+        4             ╔════╧═╗         1
+        3         ┌───╢ 6789 ║         0
+        2         │   ╚════╤═╝         -1
+        1   ╔═════╧═╗      └─── nil    -2
+        0   ╢ 12345 ║
+        -1  ╚═════╤═╝
+        -2        └─── nil            0
+
+
+                     12345    6789   nil
+height-above           5        2     0
+vertical-height-above  3        2     0
+height-below           2        2     0
+vertical-height-below  2        2     0
+
+"
+
+(defun draw-tree-view (view x y pict)
+  (if (binary-tree-empty-p (subtree-view-node view))
+      (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-string
+       pict x y (subtree-view-label view))
+      (let ((line-x  (+ x (subtree-view-label-box-width view) -3))
+            (above-y (+ y (max 2 (subtree-view-vertical-height-above view))))
+            (below-y (- y (max 2 (subtree-view-vertical-height-below view)))))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-line
+         pict line-x below-y 0 (+ 1
+                                  (subtree-view-vertical-height-above view)
+                                  (subtree-view-vertical-height-below view))
+         :foreground (getf *line* :vertical))
+
+        (apply (function COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:frame-rect)
+               pict x (1- y) (subtree-view-label-box-width view) 3 *box*)
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-point
+         pict x y (getf *line* :right-butt))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-string
+         pict (+ 2 x) y (subtree-view-label view))
+
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-line
+         pict line-x above-y 5 0 :foreground (getf *line* :horizontal))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-point
+         pict line-x (1+ y)  (getf *line* :bottom-butt))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-point
+         pict line-x above-y (getf *line* :top-left))
+
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-line
+         pict line-x below-y 5 0 :foreground (getf *line* :horizontal))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-point
+         pict line-x (1- y)  (getf *line* :top-butt))
+        (COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:draw-point
+         pict line-x below-y (getf *line* :bottom-left))
+
+        (draw-tree-view (subtree-view-right-subtree-view view) (+ line-x 4) above-y pict)
+        (draw-tree-view (subtree-view-left-subtree-view  view) (+ line-x 4) below-y pict)))
+  pict)
+
+(defun draw-tree (tree)
+  (let* ((view (binary-tree-to-view tree))
+         (pict (make-instance 'COM.INFORMATIMAGO.COMMON-LISP.PICTURE.PICTURE:PICTURE
+                   :width  (1+ (subtree-view-width  view))
+                   :height (1+ (subtree-view-height view))))
+         (x    0)
+         (y    (subtree-view-height-below view)))
+    (draw-tree-view view x y pict)
+    pict))
+
+
+;;;; THE END ;;;;
diff --git a/memoize.lisp b/memoize.lisp
new file mode 100644
index 0000000..0fe6329
--- /dev/null
+++ b/memoize.lisp
@@ -0,0 +1,215 @@
+;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-COMMON-LISP; Package: (MEMOIZE) -*-
+;; File		     - memoize.lisp
+;; Description	     - memoization
+;; Author	     - Tim Bradshaw (tfb at lostwithiel)
+;; Created On	     - 1995?
+;; Last Modified On  - Thu Apr 19 23:11:58 2007
+;; Last Modified By  - Tim Bradshaw (tfb at fowey.cley.com)
+;; Update Count	     - 13
+;; Status	     - Unknown
+;;
+;; $Id: //depot/www-tfeb-org/main/www-tfeb-org/html/programs/lisp/memoize.lisp#2 $
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;; * Memoization
+;;; Norvig p269-275
+
+;;; memoize.lisp is copyright 1995-2000 by me, Tim Bradshaw, and may
+;;; be used for any purpose whatsoever by anyone. It has no warranty
+;;; whatsoever. I would appreciate acknowledgement if you use it in
+;;; anger, and I would also very much appreciate any feedback or bug
+;;; fixes.
+
+;;; Note that memoized functions are not currently thread-safe, since
+;;; calling them can modify the structure holding the memos.
+;;;
+
+(defpackage :org.tfeb.hax.memoize
+  (:use :cl)
+  (:export #:memoize-function
+	   #:unmemoize-function #:unmemoize-functions
+	   #:clear-memoized-function #:clear-memoized-functions
+	   #:function-memoized-p
+	   #:def-memoized-function
+	   #:memoized-labels))
+
+(in-package :org.tfeb.hax.memoize)
+
+(provide :org.tfeb.hax.memoize)
+
+(defvar *memoized-functions* '()
+  ;; stores an alist of (name table old-def)
+  )
+
+(defun make-memo (fn key test)
+  ;; Return wrapper & table
+  (declare (type function fn key test))
+  (let ((table (make-hash-table :test test)))
+    (values
+      #'(lambda (&rest args)
+	  (declare (dynamic-extent args))
+	  (let ((k (funcall key args)))
+	    (multiple-value-bind (val found-p) (gethash k table)
+	      (if found-p
+		  val
+		  (setf (gethash k table)
+			(apply fn args))))))
+      table)))
+
+;;; semi user-interface fns
+
+(defun memoize-function (fn-name &key (key #'first) (test #'eql))
+  "Memoize FN-NAME, a symbol, causing its results to be stashed.
+KEY is a function which is given the arglist of FN-NAME, and should return
+a key to hash on for memoizing.  TEST is a function which  the test for the
+ashtable.
+See Norvig P269-275.
+
+Note this function may not work on self-recursive functions because the
+compiler can optimize away self-calls in various ways.
+DEF-MEMOIZED-FUNCTION should work for those cases as it is careful to ensure
+the function can not be inlined like this."
+  (declare (type symbol fn-name)
+	   (type function key test))
+  (when (not (fboundp fn-name))
+    (error "~A is not FBOUNDP" fn-name))
+  (when (assoc fn-name *memoized-functions*)
+    (error "~A is already memoized" fn-name))
+  (multiple-value-bind (wrapper table)
+      (make-memo (symbol-function fn-name) key test)
+    (push (list fn-name table (symbol-function fn-name)) *memoized-functions*)
+    (setf (symbol-function fn-name) wrapper)
+    fn-name))
+
+(defun unmemoize-function (fn-name)
+  "Remove memoization for FN-NAME"
+  (declare (type symbol fn-name))
+  (let ((hit (assoc fn-name *memoized-functions*)))
+    (when (not hit)
+      (error "~A is not memoized" fn-name))
+    (setf (symbol-function fn-name) (third hit))
+    (setf *memoized-functions* (delete hit *memoized-functions*))
+    fn-name))
+
+(defun unmemoize-functions ()
+  ;; complain about all the double-lookup & consing & I'll laugh at
+  ;; you.
+  "Unmemoize all functions"
+  (mapcar #'unmemoize-function
+	  (mapcar #'car *memoized-functions*)))
+
+(defun clear-memoized-function (fn-name)
+  "Clear memoized results for FN-NAME"
+  (declare (type symbol fn-name))
+  (let ((hit (assoc fn-name *memoized-functions*)))
+    (when (not hit)
+      (error "~A is not memoized" fn-name))
+    (clrhash (second hit))
+    fn-name))
+
+(defun clear-memoized-functions ()
+  "Clear memoized results for all functions"
+  (mapcar #'clear-memoized-function
+	  (mapcar #'car *memoized-functions*)))
+
+(defun function-memoized-p (fn-name)
+  "Is FN-NAME memoized?"
+  (declare (type symbol fn-name))
+  (if (assoc fn-name *memoized-functions*) t nil))
+
+(defmacro def-memoized-function (fnspec args &body bod)
+  "Define a memoized function.
+FNSPEC is either the name of the function, or a list suitable as an arglist
+for MEMOIZE-FUNCTION.  ARGS & BOD are passed off to DEFUN.
+
+This will declare FNSPEC NOTINLINE, which may be necessary to prevent good
+compilers optimizing away self calls & stuff like that."
+  ;; the sorts of fns that are usefully inlineable and those that are
+  ;; usefully memoizable are probably disjoint...
+  (let* ((normalized-fnspec (etypecase fnspec
+			      (symbol (list fnspec))
+			      (list fnspec)))
+	 (name (car normalized-fnspec)))
+    (when (function-memoized-p name)
+      (unmemoize-function name))
+    `(progn
+       ;; ??? is this right?  I want to ensure that the function is
+       ;; really called, and avoid bright compilers doing TRO or not
+       ;; calling through the SYMBOL-FUNCTION (kind of a strange thing
+       ;; to want in general).  I think that a NOTINLINE declaration
+       ;; does this.
+       (declaim (notinline ,name))
+       (defun ,name ,args
+	 ;; ??? can we need NOTINLINE here as well?
+	 ,@bod)
+       (apply #'memoize-function (list ',(car normalized-fnspec) ,@(cdr normalized-fnspec)))
+       ',name)))
+#||
+(def-memoized-function fib (n)
+  (if (<= n 1)
+      1
+      (+ (fib (- n 1)) (fib (- n 2)))))
+||#
+
+
+(defmacro memoized-labels ((&rest labdefs) &body bod)
+  "A version of LABELS that memoizes the local functions.  See
+MEMOIZE-FUNCTION and DEF-MEMOIZED-FUNCTION.  If code that uses this is
+compiled (either by COMPILE or COMPILE-FILE, then the table of memoized
+results will be unique, if interpreted then a new table may be generated for
+each use.  The function `names' are generalised in the same way as for
+DEF-MEMOIZED-FUNCTION."
+  ;; this is a pretty hairy macro, perhaps unnecessarily so.  It uses
+  ;; an interestingly-large amount of the features of CL.  The use of
+  ;; LOAD-TIME-VALUE is an attempt to get literal hashtables into the
+  ;; compiled code, which seems to be non-portable the obvious way
+  ;; (binding them in the macro & then splicing the literal in to the
+  ;; expansion). Can MAKE-LOAD-FORM do this better?
+  `(labels ,(loop for (fspec fargs . fbod) in labdefs
+		  collect
+		    (destructuring-bind (fname &key (key '(function first))
+						    (test '(function eql)))
+			(if (listp fspec)
+			    ;; FSPEC is of the form (NAME :key
+			    ;; .. :test ..), where we use the keywords
+			    ;; to get the key from the arglist and
+			    ;; decide what test to use for the
+			    ;; hashtable.
+			    fspec
+			    (list fspec :key '(function first)
+				  :test '(function eql)))
+		      (let ((htn (make-symbol "HT"))	;hashtable name
+			    (kn (make-symbol "K"))	;key from arglist name
+			    (vn (make-symbol "V"))	;value found name
+			    (fpn (make-symbol "FP"))	;foundp name
+			    (argsn (make-symbol "ARGS")))	;args name
+			;; here's the definition clause in the LABELS:
+			;; note we have to generalise rthe args to an
+			;; &REST, but hopefully the DYNAMIC-EXTENT
+			;; avoids too much lossage.
+			`(,fname (&rest ,argsn)
+			  (declare (dynamic-extent ,argsn)	;stop consing
+				   (notinline ,fname))	;stop TRO (?)
+			  ;; this use of LOAD-TIME-VALUE should ensure
+			  ;; that the hashtable is unique in compiled
+			  ;; code.  This has kind of interesting
+			  ;; effects, as it's shared amongst seperate
+			  ;; closures that you might return, so use of
+			  ;; one can speed up another!
+			  (let ((,htn (load-time-value (make-hash-table
+							 :test ,test)))
+				(,kn (funcall ,key ,argsn)))
+			    (multiple-value-bind (,vn ,fpn)
+				(gethash ,kn ,htn)
+			      (if ,fpn
+				  ,vn		;found in table: return value
+				  ;; didn't find it: compute value
+				  (setf (gethash ,kn ,htn)
+					(apply #'(lambda ,fargs
+						   ,@fbod)
+					       ,argsn)))))))))
+     ,@bod))
+
+;;; indentation for zmacs
+#+Genera
+(pushnew 'memoized-labels zwei:*definition-list-functions*)
ViewGit