Pascal J. Bourguignon [2011-01-01 01:42]
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*)