grapher.lisp
(defvar *drawing-method-hash* (make-hash-table))
(defstruct (graphics-device (:constructor %make-gdev)
(:conc-name gd-)
(:print-function print-gd))
display
screen
black
white
font
font-width
font-ascent
font-height
x-min
y-min
x-max
y-max
border
gc
event-mask
object-set
window
obj-list
redrawer
button-handler
)
(defun print-gd (gd stream depth)
(format stream "#<GRAPHICS-DEVICE: ~A OBJECTS>" (length (gd-obj-list gd))))
(defun make-graphics-device (name width height)
(require :clx)
(let* ((display (ext:open-clx-display
(cdr (assoc :display ext:*environment-list*))))
(screen (first (xlib:display-roots display)))
(black (xlib:screen-black-pixel screen))
(white (xlib:screen-white-pixel screen))
(font (xlib:open-font display "8x13"))
(font-width (xlib:char-width font 0))
(font-ascent (xlib:font-ascent font))
(font-height (+ font-ascent (xlib:font-descent font)))
(gc (xlib:create-gcontext :drawable (xlib:screen-root screen)
:font font :exposures nil
:fill-style :solid :fill-rule :even-odd
:foreground black :background white))
(event-mask (xlib:make-event-mask :exposure
:button-press
))
(object-set
(system:make-object-set name #'ext:default-clx-event-handler))
(window (xlib:create-window :parent (xlib:screen-root screen)
:x 350 :y 200
:width width
:height height
:border-width 5
:event-mask event-mask
:background white))
(new-gd (%make-gdev
:display display
:screen screen
:black black
:white white
:font font
:font-width font-width
:font-ascent font-ascent
:font-height font-height
:x-min 0
:y-min 0
:x-max 100
:y-max 100
:border 0.1
:GC gc
:event-mask event-mask
:object-set object-set
:redrawer #'default-redrawer
:window window)))
(labels ((exposure-handler (obj event-key window x y width height count send)
(declare (ignore obj event-key window count send))
(funcall (gd-redrawer new-gd) new-gd x y width height))
(no-exposure-handler (obj event-key window major minor send)
(declare (ignore obj event-key window major minor send)) t)
(client-message-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(xlib:unmap-window window)
(xlib:display-force-output display))
(button-press-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(if (gd-button-handler new-gd)
(funcall (gd-button-handler new-gd)
new-gd
(nth 10 lst) ;number
(nth 4 lst) ;x
(nth 5 lst))))) ;y
(ext:serve-exposure object-set #'exposure-handler)
(ext:serve-no-exposure object-set #'no-exposure-handler)
(ext:serve-client-message object-set #'client-message-handler)
(ext:serve-button-press object-set #'button-press-handler)
(ext:enable-clx-event-handling display #'ext:object-set-event-handler)
(setf (xlib:wm-name window) name)
(xlib::set-wm-protocols window '(WM_DELETE_WINDOW))
(system:add-xwindow-object window window object-set))
(xlib:map-window window)
(xlib:display-force-output display)
new-gd))
(defun graphics-set-coordinate-limits (gd x-min y-min x-max y-max)
(cond ((or (<= x-max x-min) (<= y-max y-min))
(print "Upper bound should be larger than lower.") nil)
(t (setf (gd-x-min gd) x-min)
(setf (gd-y-min gd) y-min)
(setf (gd-x-max gd) x-max)
(setf (gd-y-max gd) y-max)
(graphics-redraw gd))))
(defun graphics-coordinate-limits (gd)
(values (gd-x-min gd)
(gd-y-min gd)
(gd-x-max gd)
(gd-y-max gd)))
(defun graphics-coord-map (gd)
(lambda (x y)
(values (funcall (graphics-coord-map-x gd) x)
(funcall (graphics-coord-map-y gd) y))))
(defun graphics-coord-map-x (gd)
(lambda (x)
(let* ((x-min (gd-x-min gd))
(x-max (gd-x-max gd))
(width (graphics-device-width gd)))
(floor (* width (/ (- x x-min) (- x-max x-min)))))))
(defun graphics-coord-map-y (gd)
(lambda (y)
(let* ((y-min (gd-y-min gd))
(y-max (gd-y-max gd))
(height (graphics-device-height gd)))
(- height (floor (* height (/ (- y y-min) (- y-max y-min))))))))
(defun graphics-length-map-x (gd)
(lambda (len)
(let* ((x-min (gd-x-min gd))
(x-max (gd-x-max gd))
(width (graphics-device-width gd)))
(floor (* width (/ len (- x-max x-min)))))))
(defun graphics-length-map-y (gd)
(lambda (len)
(let* ((y-min (gd-y-min gd))
(y-max (gd-y-max gd))
(height (graphics-device-height gd)))
(floor (* height (/ len (- y-max y-min)))))))
; (funcall (graphics-coord-map gd1) 30 30)
; (funcall (graphics-length-map-x gd1) 30)
(defun default-redrawer (gd x y width height)
(let* ((window (gd-window gd))
(display (gd-display gd))
(obj-list (gd-obj-list gd))
(gc (gd-gc gd))
(font (gd-font gd)))
(unless (eq (xlib:window-map-state window) :viewable)
(xlib:map-window window)
(xlib:display-force-output display))
;; clear the whole window
(xlib:clear-area window :x 0 :y 0 :width (xlib:drawable-width window)
:height (xlib:drawable-height window))
(xlib:display-force-output display)
;; draw objects
(dolist (obj obj-list)
(let ((drawer (gethash (car obj) *drawing-method-hash*)))
;(print obj) (print drawer)
(if drawer
(apply drawer gd (cdr obj))
(format t "I Don't know how to draw the type ~A" (car obj)))))
(xlib:display-force-output display)))
; (setf (gd-redrawer gd1) #'default-redrawer)
; (gd-obj-list gd1)
(defun register-drawer (type proc)
(setf (gethash type *drawing-method-hash*) proc))
(defmacro with-graphics-device (gd &body body)
`(let* ((window (gd-window ,gd))
(display (gd-display ,gd))
(obj-list (gd-obj-list ,gd))
(gc (gd-gc ,gd))
(font (gd-font ,gd))
(x-min (gd-x-min ,gd))
(y-min (gd-y-min ,gd))
(x-max (gd-x-max ,gd))
(y-max (gd-y-max ,gd))
(coord-map (graphics-coord-map ,gd))
(coord-map-x (graphics-coord-map-x ,gd))
(coord-map-y (graphics-coord-map-y ,gd))
(length-map-x (graphics-length-map-x ,gd))
(length-map-y (graphics-length-map-y ,gd))
(width (graphics-device-width ,gd))
(height (graphics-device-height ,gd)))
,@body))
(defun graphics-redraw (gd)
(with-graphics-device gd
(funcall (gd-redrawer gd) gd 0 0 width height)))
; (graphics-redraw gd1)
(defun graphics-flush (gd)
(xlib:display-force-output (gd-display gd)))
(defun graphics-clear (gd)
(with-graphics-device gd
(setf (gd-obj-list gd) nil)
(xlib:clear-area window :x 0 :y 0 :width (xlib:drawable-width window)
:height (xlib:drawable-height window))
(xlib:display-force-output display)))
(defmacro define-drawer (drawer-name redrawer-name args &body body)
(let ((type-tag (let ((type (cadr (memq '&type args))))
(if type (progn (setf args (remove-n '&type args 2))
type)
(gensym))))
(new-drawer (gensym))
(obj (gensym))
(gd (gensym))
(n-args (length args)))
`(let ((,new-drawer #'(lambda ,args ,@body)))
(register-drawer ',type-tag ,new-drawer)
(defun ,drawer-name (,gd ,@(cdr args))
(let* ((,obj (list ',type-tag ,@(cdr args))))
(push ,obj (gd-obj-list ,gd))
(apply ,new-drawer ,gd (list ,@(cdr args)))
(graphics-flush ,gd)
,obj))
(defun ,redrawer-name (,gd ,obj &rest lst)
(cond ((null lst)
(setf (gd-obj-list ,gd)
(remove ,obj (gd-obj-list ,gd)))
(graphics-redraw ,gd)
,obj)
((not (= (length lst) ,(- n-args 1)))
(format t "~&~A : accept ~A args, get ~A~%"
,(symbol-name redrawer-name) ,(+ n-args 1) (+ (length lst) 2)))
(t
(setf (cdr ,obj) lst)
(if (not (memq ,obj (gd-obj-list ,gd)))
(push ,obj (gd-obj-list ,gd)))
(graphics-redraw ,gd) ,obj))
))))
(define-drawer graphics-draw-dot graphics-redraw-dot
(gd x y radius &type :dot)
(with-graphics-device gd
(xlib:draw-arc window gc
(- (funcall coord-map-x x) radius)
(- (funcall coord-map-y y) radius)
(* 2 radius)
(* 2 radius)
0 (* 2 3.14159) t)))
(define-drawer graphics-draw-circle graphics-redraw-circle
(gd x y radius &type :circle)
(with-graphics-device gd
(xlib:draw-arc window gc
(funcall coord-map-x (- x radius))
(funcall coord-map-y (+ y radius))
(funcall length-map-x (* 2 radius))
(funcall length-map-y (* 2 radius))
0 (* 2 3.14159))))
(define-drawer graphics-draw-line graphics-redraw-line
(gd x1 y1 x2 y2 &type :line)
(with-graphics-device gd
(xlib:draw-line window gc
(funcall coord-map-x x1)
(funcall coord-map-y y1)
(funcall coord-map-x x2)
(funcall coord-map-y y2))))
(define-drawer graphics-draw-rect graphics-redraw-rect
(gd x y w h &type :rect)
(with-graphics-device gd
(xlib:draw-rectangle window gc
(funcall coord-map-x x)
(funcall coord-map-y y)
(funcall length-map-x w)
(funcall length-map-y h))))
(define-drawer graphics-draw-text graphics-redraw-text
(gd x y text &type :text)
(with-graphics-device gd
(xlib:draw-glyphs window gc (funcall coord-map-x x)
(funcall coord-map-y y) text)))
(defun graphics-device-width (gd)
(xlib:drawable-width (gd-window gd)))
(defun graphics-device-height (gd)
(xlib:drawable-height (gd-window gd)))
; (graphics-device-width gd1)
(defun close-graphics-device (g)
(xlib:unmap-window (gd-window g))
(xlib:display-finish-output (gd-display g))
(xlib:close-font (gd-font g))
(xlib:free-gcontext (gd-gc g))
(xlib:close-display (gd-display g)))
;; (setf gd1 (make-graphics-device "hello" 300 300))
;; (graphics-set-coordinate-limits gd1 0 0 200 200)
;; (graphics-draw-text gd1 50 20 "wang yin")
;; (graphics-draw-rect gd1 30 50 10 10)
;; (graphics-draw-line gd1 0 0 30 70)
;; (graphics-draw-line gd1 30 70 50 50)
;; (graphics-draw-circle gd1 50 50 20)
;; (loop for x = 1 then (* 1.3 x)
;; until (> x 200)
;; do (graphics-draw-circle gd1 0 0 x))
;; (setf dot1 (graphics-draw-dot gd1 70 40 20))
;; (setf (fourth dot1) 40)
;; (graphics-redraw-dot gd1 dot1)
;; (setf wy (graphics-draw-text gd1 0 0 "rect. delaunay for 20 sites "))
;; (graphics-redraw-text gd1 wy 80 40 "kick")
;; (graphics-redraw-text gd1 wy 100000 1729741 "rect. delaunay for 20 sites ")
;; (graphics-clear gd1)
;; (funcall (graphics-length-map-x gd1) 5)
;; (graphics-flush gd1)
;; (cadr (gd-obj-list gd1))
;; (graphics-redraw-text gd1 (cadr (gd-obj-list gd1)))
sdraw-cmucl.lisp
;;; -*- Mode: Lisp; Package: SDRAW -*-
;;;
;;; SDRAW - draws cons cell structures.
;;;
;;; From the book "Common Lisp: A Gentle Introduction to
;;; Symbolic Computation" by David S. Touretzky.
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This version is for CMU Common Lisp with CLX support for X Windows.
;;; Revised to include support for circular structures.
;;;
;;; User-level routines:
;;; (SDRAW obj) - draws obj on the display
;;; (SDRAW-LOOP) - puts the user in a read-eval-draw loop
;;; (SCRAWL obj) - interactively crawl around obj
;;;
;;; Variables:
;;; *SDRAW-PRINT-CIRCLE* If bound, overrides *PRINT-CIRCLE*.
;;; *SDRAW-LEADING-ARROW* Initially NIL. Set to T to get leading arrows.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The parameters below are in units of characters (horizontal)
;;; and lines (vertical). They apply to all versions of SDRAW,
;;; but their values may change if cons cells are being drawn as
;;; bit maps rather than as character sequences.
(defparameter *sdraw-display-width* 79.)
(defparameter *sdraw-display-height* 24.)
(defparameter *sdraw-horizontal-atom-cutoff* 79.)
(defparameter *sdraw-horizontal-cons-cutoff* 65.)
(defparameter *etc-string* "etc.")
(defparameter *etc-spacing* 4.)
(defparameter *inter-atom-h-spacing* 3.)
(defparameter *cons-atom-h-arrow-length* 9.)
(defparameter *inter-cons-v-arrow-length* 3.)
(defparameter *cons-v-arrow-offset-threshold* 2.)
(defparameter *cons-v-arrow-offset-value* 1.)
(defparameter *leading-arrow-length* 4)
(defparameter *sdraw-num-lines* 25)
(defparameter *sdraw-vertical-cutoff* 22.)
(defvar *sdraw-leading-arrow* nil)
(defvar *sdraw-print-circle*)
(defvar *sdraw-circular-switch*)
(defvar *circ-detected* nil)
(defvar *circ-label-counter* 0)
(defparameter *circ-hash-table* (make-hash-table :test #'eq :size 20))
(defvar *line-endings* (make-array *sdraw-num-lines*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW and subordinate definitions.
(defun sdraw (obj &aux (*circ-detected* nil))
(let ((*sdraw-circular-switch*
(if (boundp '*sdraw-print-circle*) *sdraw-print-circle*
*print-circle*))
(start-col (if *sdraw-leading-arrow* *leading-arrow-length* 0)))
(init-struct1 start-col)
(clrhash *circ-hash-table*)
(let* ((first-layout (struct1 obj 0 start-col 0 nil))
(second-layout (when *circ-detected*
(init-struct1 start-col)
(struct1 obj 0 start-col 0 t))))
(draw-structure (or second-layout first-layout))
(values))))
(defun init-struct1 (start-col)
(setf *circ-label-counter* 0)
(fill *line-endings* most-negative-fixnum)
(struct-record-position 0 (- start-col *inter-atom-h-spacing*)))
(defun never-seen? (obj)
(null (gethash obj *circ-hash-table*)))
(defun seen-twice? (obj)
(numberp (gethash obj *circ-hash-table*)))
(defun needs-label? (obj)
(zerop (gethash obj *circ-hash-table*)))
(defun struct1 (obj row root-col adj second-pass)
(cond ((>= row *sdraw-vertical-cutoff*) (struct-process-etc row root-col adj))
((not second-pass)
(enter-in-hash-table obj)
(struct-first-pass obj row root-col adj))
(t (struct-second-pass obj row root-col adj))))
(defun enter-in-hash-table (obj)
(unless (or (not *sdraw-circular-switch*)
(numberp obj)
(and (symbolp obj) (symbol-package obj)))
(cond ((never-seen? obj) (setf (gethash obj *circ-hash-table*) t))
(t (setf (gethash obj *circ-hash-table*) 0)
(setf *circ-detected* t)))))
(defun struct-first-pass (obj row root-col adj)
(if (seen-twice? obj)
(struct-process-circ-reference obj row root-col adj)
(if (atom obj)
(struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
(struct-unlabeled-cons obj row root-col adj nil))))
(defun struct-second-pass (obj row root-col adj)
(cond ((not (seen-twice? obj))
(if (atom obj)
(struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
(struct-unlabeled-cons obj row root-col adj t)))
((needs-label? obj)
(if (atom obj)
(struct-label-atom obj row root-col adj)
(struct-label-cons obj row root-col adj)))
(t (struct-process-circ-reference obj row root-col adj))))
;;; Handle the simplest case: an atom or cons with no #n= label.
(defun struct-unlabeled-atom (atom-string row root-col adj)
(let* ((start-col (struct-find-start row root-col adj))
(end-col (+ start-col adj (length atom-string))))
(cond ((< end-col *sdraw-horizontal-atom-cutoff*)
(struct-record-position row end-col)
(list 'atom row (+ start-col adj) atom-string))
(t (struct-process-etc row root-col adj)))))
(defun struct-unlabeled-cons (obj row root-col adj second-pass)
(let* ((cons-start (struct-find-start row root-col adj))
(car-structure
(struct1 (car obj)
(+ row *inter-cons-v-arrow-length*)
cons-start adj second-pass))
(start-col (third car-structure)))
(if (>= start-col *sdraw-horizontal-cons-cutoff*)
(struct-process-etc row root-col adj)
(progn
(struct-record-position row (- (+ start-col
*cons-atom-h-arrow-length*)
adj *inter-atom-h-spacing*))
(list 'cons row start-col car-structure
(struct1 (cdr obj) row (+ start-col *cons-atom-h-arrow-length*)
0 second-pass))))))
(defun struct-process-etc (row root-col adj)
(let ((start-col (struct-find-start row root-col adj)))
(struct-record-position
row
(+ start-col adj (length *etc-string*) *etc-spacing*))
(list 'msg row (+ start-col adj) *etc-string*)))
;;; Handle objects that need to be labeled with #n=.
;;; Called only on the second pass.
(defun struct-label-atom (obj row root-col adj)
(assign-label obj)
(let* ((circ-string (format nil "#~S=" (gethash obj *circ-hash-table*)))
(newadj (struct-find-adj row root-col adj (length circ-string)))
(atom-string (format nil "~S" obj))
(start-col (struct-find-start row root-col adj))
(end-col (+ start-col newadj (length atom-string))))
(cond ((< end-col *sdraw-horizontal-atom-cutoff*)
(struct-record-position row end-col)
(list 'atom row (+ start-col newadj) atom-string circ-string))
(t (struct-process-etc row root-col adj)))))
(defun struct-label-cons (obj row root-col adj)
(assign-label obj)
(let* ((string (format nil "#~S=" *circ-label-counter*))
(newadj (struct-find-adj row root-col adj (length string)))
(cons-start (struct-find-start row root-col adj))
(car-structure
(struct1 (car obj)
(+ row *inter-cons-v-arrow-length*)
cons-start newadj t))
(start-col (third car-structure)))
(if (>= start-col *sdraw-horizontal-cons-cutoff*)
(struct-process-etc row root-col adj)
(progn
(struct-record-position row (- (+ start-col
*cons-atom-h-arrow-length*)
adj *inter-atom-h-spacing*))
(list 'cons row start-col car-structure
(struct1 (cdr obj) row
(+ start-col *cons-atom-h-arrow-length*) 0 t)
string)))))
(defun assign-label (obj)
(setf (gethash obj *circ-hash-table*)
(incf *circ-label-counter*)))
;;; Handle circular references by displaying them as #n#.
;;; When called on the first pass, this function always uses a label of 0.
;;; It will get the label right on the second pass.
(defun struct-process-circ-reference (obj row root-col adj)
(let ((start-col (struct-find-start row root-col adj))
(string (format nil "#~S#" (gethash obj *circ-hash-table*))))
(struct-record-position
row
(+ (+ start-col adj) (length string)))
(list 'msg row (+ start-col adj) string)))
;;; Support functions.
(defun struct-find-start (row root-col adj)
(max root-col
(- (+ *inter-atom-h-spacing* (aref *line-endings* row)) adj)))
(defun struct-find-adj (row col adj size)
(let* ((line-end (max 0 (+ *inter-atom-h-spacing*
(aref *line-endings* row))))
(newadj (- line-end (- col (max size adj)))))
(max adj (min (max newadj 0) size))))
(defun struct-record-position (row end-col)
(setf (aref *line-endings* row) end-col))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW-LOOP and subordinate definitions.
(defparameter *sdraw-loop-prompt-string* "S> ")
(defun sdraw-loop ()
"Read-eval-print loop using sdraw to display results."
(format t "~&Type any Lisp expression, or (ABORT) to exit.~%~%")
(sdl1))
(defun sdl1 ()
(loop
(format t "~&~A" *sdraw-loop-prompt-string*)
(force-output t)
(let ((form (read)))
(setf +++ ++
++ +
+ -
- form)
(let ((result (multiple-value-list
(handler-case (eval form)
(error (condx) condx)))))
(typecase (first result)
(error (display-sdl-error result))
(t (setf /// //
// /
/ result
*** **
** *
* (first result))
(display-sdl-result *)))))))
(defun display-sdl-result (result)
(sdraw result)
(let* ((*print-circle* (if (boundp '*sdraw-print-circle*)
*sdraw-print-circle*
*print-circle*))
(*print-length* nil)
(*print-level* nil)
(*print-pretty* #+cmu t #-cmu nil)
(full-text (format nil "Result: ~S" result))
(text (if (> (length full-text)
*sdraw-display-width*)
(concatenate 'string
(subseq full-text 0 (- *sdraw-display-width* 4))
"...)")
full-text)))
(if (consp result)
(format t "~%~A~%" text))
(terpri)))
(defun display-sdl-error (error)
(format t "~A~%~%" error))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SCRAWL and subordinate definitions.
(defparameter *scrawl-prompt-string* "SCRAWL> ")
(defvar *scrawl-object* nil)
(defvar *scrawl-current-obj* nil)
(defvar *extracting-sequence* nil)
(defun scrawl (obj)
"Read-eval-print loop to travel through list"
(format t "~&Crawl through list: 'H' for help, 'Q' to quit.~%~%")
(setf *scrawl-object* obj)
(scrawl-start-cmd)
(scrawl1))
(defun scrawl1 ()
(loop
(format t "~&~A" *scrawl-prompt-string*)
(let ((command (read-uppercase-char)))
(case command
(#\A (scrawl-car-cmd))
(#\D (scrawl-cdr-cmd))
(#\B (scrawl-back-up-cmd))
(#\S (scrawl-start-cmd))
(#\H (display-scrawl-help))
(#\Q (return))
(t (display-scrawl-error))))))
(defun scrawl-car-cmd ()
(cond ((consp *scrawl-current-obj*)
(push 'car *extracting-sequence*)
(setf *scrawl-current-obj* (car *scrawl-current-obj*)))
(t (format t
"~&Can't take CAR or CDR of an atom. Use B to back up.~%")))
(display-scrawl-result))
(defun scrawl-cdr-cmd ()
(cond ((consp *scrawl-current-obj*)
(push 'cdr *extracting-sequence*)
(setf *scrawl-current-obj* (cdr *scrawl-current-obj*)))
(t (format t
"~&Can't take CAR or CDR of an atom. Use B to back up.~%")))
(display-scrawl-result))
(defun scrawl-back-up-cmd ()
(cond (*extracting-sequence*
(pop *extracting-sequence*)
(setf *scrawl-current-obj*
(extract-obj *extracting-sequence* *scrawl-object*)))
(t (format t "~&Already at beginning of object.")))
(display-scrawl-result))
(defun scrawl-start-cmd ()
(setf *scrawl-current-obj* *scrawl-object*)
(setf *extracting-sequence* nil)
(display-scrawl-result))
(defun extract-obj (seq obj)
(reduce #'funcall
seq
:initial-value obj
:from-end t))
; (extract-obj '(car cdr cdr) '(1 2 3 4 5 6 7 8))
(defun get-car/cdr-string ()
(if (null *extracting-sequence*)
(format nil "'~S" *scrawl-object*)
(format nil "(c~Ar '~S)"
(map 'string #'(lambda (x)
(ecase x
(car #\a)
(cdr #\d)))
*extracting-sequence*)
*scrawl-object*)))
(defun display-scrawl-result (&aux (*print-length* nil)
(*print-level* nil)
(*print-pretty* #+cmu t #-cmu nil)
(*print-circle* t))
(let* ((extract-string (get-car/cdr-string))
(text (if (> (length extract-string) *sdraw-display-width*)
(concatenate 'string
(subseq extract-string 0
(- *sdraw-display-width* 4))
"...)")
extract-string)))
(sdraw *scrawl-current-obj*)
(format t "~&~%~A~%~%" text)))
(defun display-scrawl-help ()
(format t "~&Legal commands: A)car D)cdr B)back up~%")
(format t "~& S)start Q)quit H)help~%"))
(defun display-scrawl-error ()
(format t "~&Illegal command.~%")
(display-scrawl-help))
(defun read-uppercase-char ()
(let ((response (read-line)))
(and (plusp (length response))
(char-upcase (char response 0)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; X11 constants and event handlers.
;;;
(require :clx)
(defvar *DISPLAY* (ext:open-clx-display
(cdr (assoc :display ext:*environment-list*))))
(defvar *SCREEN* (first (xlib:display-roots *display*)))
(defvar *BLACK* (xlib:screen-black-pixel *screen*))
(defvar *WHITE* (xlib:screen-white-pixel *screen*))
(defvar *FONT* (xlib:open-font *display* "8x13"))
(defvar *FONT-WIDTH* (xlib:char-width *font* 0) "works for fixed-size fonts")
(defvar *FONT-ASCENT* (xlib:font-ascent *font*))
(defvar *FONT-HEIGHT* (+ *font-ascent* (xlib:font-descent *font*)))
(defvar *GC* (xlib:create-gcontext :drawable (xlib:screen-root *screen*)
:font *font* :exposures nil
:fill-style :solid :fill-rule :even-odd
:foreground *black* :background *white*))
;;; X11 Event Handling (exposure events)
(defvar *x-object-set*
(system:make-object-set "SDraw Window" #'ext:default-clx-event-handler))
(defvar *events* (xlib:make-event-mask :exposure
:button-press
:resize-redirect))
(defun exposure-handler (obj event-key window x y width height count send)
(declare (ignore obj event-key window x y width height count send))
(do-redraw))
(defun no-exposure-handler (obj event-key window major minor send)
(declare (ignore obj event-key window major minor send)) t)
(defun button-press-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(if *scrawl-object*
(case (nth 10 lst)
(1 (scrawl-car-cmd))
(2 (scrawl-back-up-cmd))
(3 (scrawl-cdr-cmd)))))
;; (defun resize-request-handler (obj event-key &rest lst)
;; (declare (ignore obj event-key))
;; (do-redraw))
(defun client-message-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(hide-window))
(ext:serve-exposure *x-object-set* #'exposure-handler)
(ext:serve-no-exposure *x-object-set* #'no-exposure-handler)
(ext:serve-client-message *x-object-set* #'client-message-handler)
(ext:serve-button-press *x-object-set* #'button-press-handler)
;; (ext:serve-resize-request *x-object-set* #'resize-request-handler)
(defun enable-X11-handler ()
(ext:enable-clx-event-handling *display* #'ext:object-set-event-handler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; X11 Window: window-row and window-col translate char coordinates into
;;; pixel coordinates. init-window creates the X11 window and starts up the
;;; event handler. do-redraw is the function called when a redraw event
;;; is requested, it handles resizing also.
(defun window-row (row &optional (offset 0)) (+ (* row *font-height*) offset))
(defun window-col (col &optional (offset 0)) (+ (* col *font-width*) offset))
(defvar *WINDOW-H-OFFSET* (* 2 *font-width*) "horizontal offset")
(defvar *WINDOW-V-OFFSET* (* 2 *font-height*) "vertical offset")
(defvar *WINDOW-WIDTH* (window-col *sdraw-display-width*
(* 2 *window-h-offset*)))
(defvar *WINDOW-HEIGHT* (window-row *sdraw-display-height*
(* 2 *window-v-offset*)))
(defvar *WINDOW* (xlib:create-window :parent (xlib:screen-root *screen*)
:x 350 :y 200
:width *window-width*
:height *window-height*
:border-width 5
:event-mask *events*
:background *white*))
(defun init-window ()
(enable-X11-handler)
(setf (xlib:wm-name *window*) "SDraw")
(xlib::set-wm-protocols *window* '(WM_DELETE_WINDOW))
(system:add-xwindow-object *window* *window* *x-object-set*))
(init-window)
(defun hide-window ()
(xlib:unmap-window *window*)
(xlib:display-force-output *display*))
(defvar *old-window-height* (xlib:drawable-height *window*))
(defvar *old-window-width* (xlib:drawable-width *window*))
(defun do-redraw ()
(let ((h (xlib:drawable-height *window*))
(w (xlib:drawable-width *window*)))
(unless (and (eq h *old-window-height*) ; check for resize
(eq w *old-window-width*))
(setf *old-window-height* h)
(setf *old-window-width* w)
(decf h (* 2 *window-h-offset*))
(decf w (* 2 *window-v-offset*))
(setf *sdraw-display-width* (floor w *font-width*))
(setf *sdraw-display-height* (floor h *font-height*))
(setf *sdraw-vertical-cutoff* (- *sdraw-display-height* 3))
(setf *sdraw-horizontal-atom-cutoff* (1- *sdraw-display-width*))
(setf *sdraw-horizontal-cons-cutoff* (- *sdraw-display-width* 15))
(setf *line-endings*
(make-array *sdraw-display-height* :initial-element most-negative-fixnum)))
(dump-display)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The following definitions are specific to the X11 implementation.
(defvar *cons-width* 40)
(defvar *cons-height* 15)
(defvar *arrowhead-from-point* 8)
(defvar *arrowhead-from-axis* 5)
(defvar *obj-list* nil)
(defun arrowhead (x y type)
(ecase type
(:horiz
`((:line ,x ,y ,(- x *arrowhead-from-point*)
,(- y *arrowhead-from-axis*))
(:line ,x ,y ,(- x *arrowhead-from-point*)
,(+ y *arrowhead-from-axis*))))
(:vert
`((:line ,x ,y ,(- x *arrowhead-from-axis*)
,(- y *arrowhead-from-point*))
(:line ,x ,y ,(+ x *arrowhead-from-axis*)
,(- y *arrowhead-from-point*))))))
(defun draw-structure (directions)
(setf *obj-list* nil)
(follow-directions directions)
(dump-display))
(defun follow-directions (dirs &optional is-car)
(ecase (car dirs)
(cons (draw-cons dirs))
((atom msg) (draw-msg dirs is-car))))
(defun draw-cons (obj)
(let* ((row (1- (window-row (second obj) *window-v-offset*)))
(col (window-col (third obj) *window-h-offset*))
(car-component (fourth obj))
(cdr-component (fifth obj))
(string (sixth obj))
(h-arrow-start-x (floor (+ col (* 0.75 *cons-width*))))
(v-arrow-start-x (floor (+ col (* 0.25 *cons-width*))))
(arrow-start-y (floor (+ row (* 0.5 *cons-height*))))
(circle-offset (floor (* 0.08 *cons-width*)))
(circle-y (- arrow-start-y circle-offset))
(v-arrowhead-row (+ row (* *font-height* 3)))
(h-arrowhead-col (1- (window-col (third cdr-component)
*window-h-offset*)))
(cdr-string? (if (eq 'cons (first cdr-component))
(sixth cdr-component)
(fifth cdr-component))))
(if cdr-string? (decf h-arrowhead-col (length cdr-string?)))
(when string
(push `(:text ,(- col (window-col (length string)))
,(+ row *font-ascent*) ,string)
*obj-list*))
(push `(:rect ,col ,row ,*cons-width* ,*cons-height*) *obj-list*)
(push `(:circle ,(- v-arrow-start-x circle-offset) ,circle-y) *obj-list*)
(push `(:circle ,(- h-arrow-start-x circle-offset) ,circle-y) *obj-list*)
(push `(:line ,(+ col (floor *cons-width* 2)) ,row
,(+ col (floor *cons-width* 2)) ,(+ row *cons-height*))
*obj-list*)
(push `(:line ,h-arrow-start-x ,arrow-start-y
,h-arrowhead-col ,arrow-start-y) *obj-list*)
(setf *obj-list* (append (arrowhead h-arrowhead-col arrow-start-y :horiz)
*obj-list*))
(push `(:line ,v-arrow-start-x ,arrow-start-y
,v-arrow-start-x ,v-arrowhead-row) *obj-list*)
(setf *obj-list* (append (arrowhead v-arrow-start-x v-arrowhead-row :vert)
*obj-list*))
(follow-directions car-component t)
(follow-directions cdr-component)))
(defun draw-msg (obj is-car)
(let* ((row (second obj))
(col (third obj))
(string (fourth obj))
(circ-string (fifth obj)))
(when circ-string
(setf string (concatenate 'string circ-string string))
(decf col (length circ-string)))
(push `(:text ,(+ (window-col col *window-h-offset*)
(if (and is-car (<= (length string)
*cons-v-arrow-offset-threshold*))
(* *cons-v-arrow-offset-value* *font-width*)
(if is-car 0 5)))
,(+ *font-ascent* (window-row row *window-v-offset*))
,string) *obj-list*)))
(defconstant *diameter* 7)
(defun create-circle ()
(let ((pix (xlib:create-pixmap :width *diameter* :height *diameter*
:depth (xlib:drawable-depth *window*)
:drawable *window*))
(data '((2 4)(1 5)(0 6)(0 6)(0 6)(1 5)(2 4))))
(xlib:with-gcontext (*gc* :foreground *white*)
(xlib:draw-rectangle pix *gc* 0 0 *diameter* *diameter* t))
(do* ((line data (cdr line))
(x-data (car line) (car line))
(y 0 (1+ y)))
((null line) pix)
(xlib:draw-line pix *gc* (first x-data) y (second x-data) y))))
(defvar *circle* (create-circle))
;; (push `(:line 30 30 60 40) *obj-list*) (setf *obj-list* nil)
;; (push `(:circle 60 30) *obj-list*)
;; (xlib:copy-area *circle* *gc* 0 0 *diameter* *diameter*
;; *window* 30 30)
;; (xlib:draw-line *window* *gc* 30 30 60 40)
;; (xlib:display-force-output *display*)
(defun dump-display ()
(unless (eq (xlib:window-map-state *window*) :viewable)
(xlib:map-window *window*)
(xlib:display-force-output *display*))
(xlib:clear-area *window* :x 0 :y 0 :width (xlib:drawable-width *window*)
:height (xlib:drawable-height *window*))
(xlib:display-finish-output *display*)
(dolist (obj *obj-list*)
(ecase (first obj)
(:line (xlib:draw-line *window* *gc* (second obj) (third obj)
(fourth obj) (fifth obj)))
(:rect (xlib:draw-rectangle *window* *gc* (second obj) (third obj)
(fourth obj) (fifth obj)))
(:text (xlib:draw-glyphs *window* *gc* (second obj) (third obj)
(fourth obj)))
(:circle (xlib:copy-area *circle* *gc* 0 0 *diameter* *diameter*
*window* (second obj) (third obj)))))
(xlib:display-force-output *display*))
(defun display-scrawl-result (&aux (*print-pretty* #+cmu t #-cmu nil)
(*print-length* nil)
(*print-level* nil)
(*print-circle* t))
(let* ((extract-string (get-car/cdr-string))
(text (if (> (length extract-string) *sdraw-display-width*)
(concatenate 'string
(subseq extract-string 0
(- *sdraw-display-width* 4))
"...)")
extract-string)))
(sdraw *scrawl-current-obj*)
(xlib:draw-glyphs *window* *gc* *window-h-offset*
(- (xlib:drawable-height *window*) *window-v-offset* 3)
text)
(xlib:display-force-output *display*)))
sdraw.lisp
;;; -*- Mode: Lisp; Package: SDRAW -*-
;;;
;;; SDRAW - draws cons cell structures.
;;;
;;; From the book "Common Lisp: A Gentle Introduction to
;;; Symbolic Computation" by David S. Touretzky.
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This is the generic version; it will work in any legal Common Lisp.
;;; Revised to include support for circular structures.
;;;
;;; User-level routines:
;;; (SDRAW obj) - draws obj on the display
;;; (SDRAW-LOOP) - puts the user in a read-eval-draw loop
;;; (SCRAWL obj) - interactively crawl around obj
;;;
;;; Variables:
;;; *SDRAW-PRINT-CIRCLE* If bound, overrides *PRINT-CIRCLE*.
;;; *SDRAW-LEADING-ARROW* Initially NIL. Set to T to get leading arrows.
;;;
;; (in-package :cl-user)
;; (defpackage "SDRAW"
;; (:use "CL" )
;; (:nicknames "sdraw" "sd")
;; (:export "SDRAW"))
;; (pushnew :sdraw *features*)
;; (in-package "SDRAW")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The parameters below are in units of characters (horizontal)
;;; and lines (vertical). They apply to all versions of SDRAW,
;;; but their values may change if cons cells are being drawn as
;;; bit maps rather than as character sequences.
(defparameter *sdraw-display-width* 79.)
(defparameter *sdraw-horizontal-atom-cutoff* 79.)
(defparameter *sdraw-horizontal-cons-cutoff* 65.)
(defparameter *etc-string* "etc.")
(defparameter *etc-spacing* 4.)
(defparameter *inter-atom-h-spacing* 3.)
(defparameter *cons-atom-h-arrow-length* 9.)
(defparameter *inter-cons-v-arrow-length* 3.)
(defparameter *cons-v-arrow-offset-threshold* 2.)
(defparameter *cons-v-arrow-offset-value* 1.)
(defparameter *leading-arrow-length* 4)
(defparameter *sdraw-num-lines* 25)
(defparameter *sdraw-vertical-cutoff* 22.)
(defvar *sdraw-leading-arrow* nil)
(defvar *sdraw-print-circle*)
(defvar *sdraw-circular-switch*)
(defvar *circ-detected* nil)
(defvar *circ-label-counter* 0)
(defparameter *circ-hash-table* (make-hash-table :test #'eq :size 20))
(defvar *line-endings* (make-array *sdraw-num-lines*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW and subordinate definitions.
(defun sdraw (obj &aux (*circ-detected* nil))
(let ((*sdraw-circular-switch*
(if (boundp '*sdraw-print-circle*) *sdraw-print-circle*
*print-circle*))
(start-col (if *sdraw-leading-arrow* *leading-arrow-length* 0)))
(init-struct1 start-col)
(clrhash *circ-hash-table*)
(let* ((first-layout (struct1 obj 0 start-col 0 nil))
(second-layout (when *circ-detected*
(init-struct1 start-col)
(struct1 obj 0 start-col 0 t))))
(draw-structure (or second-layout first-layout))
(values))))
(defun init-struct1 (start-col)
(setf *circ-label-counter* 0)
(fill *line-endings* most-negative-fixnum)
(struct-record-position 0 (- start-col *inter-atom-h-spacing*)))
(defun never-seen? (obj)
(null (gethash obj *circ-hash-table*)))
(defun seen-twice? (obj)
(numberp (gethash obj *circ-hash-table*)))
(defun needs-label? (obj)
(zerop (gethash obj *circ-hash-table*)))
(defun struct1 (obj row root-col adj second-pass)
(cond ((>= row *sdraw-vertical-cutoff*) (struct-process-etc row root-col adj))
((not second-pass)
(enter-in-hash-table obj)
(struct-first-pass obj row root-col adj))
(t (struct-second-pass obj row root-col adj))))
(defun enter-in-hash-table (obj)
(unless (or (not *sdraw-circular-switch*)
(numberp obj)
(and (symbolp obj) (symbol-package obj)))
(cond ((never-seen? obj) (setf (gethash obj *circ-hash-table*) t))
(t (setf (gethash obj *circ-hash-table*) 0)
(setf *circ-detected* t)))))
(defun struct-first-pass (obj row root-col adj)
(if (seen-twice? obj)
(struct-process-circ-reference obj row root-col adj)
(if (atom obj)
(struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
(struct-unlabeled-cons obj row root-col adj nil))))
(defun struct-second-pass (obj row root-col adj)
(cond ((not (seen-twice? obj))
(if (atom obj)
(struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
(struct-unlabeled-cons obj row root-col adj t)))
((needs-label? obj)
(if (atom obj)
(struct-label-atom obj row root-col adj)
(struct-label-cons obj row root-col adj)))
(t (struct-process-circ-reference obj row root-col adj))))
;;; Handle the simplest case: an atom or cons with no #n= label.
(defun struct-unlabeled-atom (atom-string row root-col adj)
(let* ((start-col (struct-find-start row root-col adj))
(end-col (+ start-col adj (length atom-string))))
(cond ((< end-col *sdraw-horizontal-atom-cutoff*)
(struct-record-position row end-col)
(list 'atom row (+ start-col adj) atom-string))
(t (struct-process-etc row root-col adj)))))
(defun struct-unlabeled-cons (obj row root-col adj second-pass)
(let* ((cons-start (struct-find-start row root-col adj))
(car-structure
(struct1 (car obj)
(+ row *inter-cons-v-arrow-length*)
cons-start adj second-pass))
(start-col (third car-structure)))
(if (>= start-col *sdraw-horizontal-cons-cutoff*)
(struct-process-etc row root-col adj)
(progn
(struct-record-position row (- (+ start-col
*cons-atom-h-arrow-length*)
adj *inter-atom-h-spacing*))
(list 'cons row start-col car-structure
(struct1 (cdr obj) row (+ start-col *cons-atom-h-arrow-length*)
0 second-pass))))))
(defun struct-process-etc (row root-col adj)
(let ((start-col (struct-find-start row root-col adj)))
(struct-record-position
row
(+ start-col adj (length *etc-string*) *etc-spacing*))
(list 'msg row (+ start-col adj) *etc-string*)))
;;; Handle objects that need to be labeled with #n=.
;;; Called only on the second pass.
(defun struct-label-atom (obj row root-col adj)
(assign-label obj)
(let* ((circ-string (format nil "#~S=" (gethash obj *circ-hash-table*)))
(newadj (struct-find-adj row root-col adj (length circ-string)))
(atom-string (format nil "~S" obj))
(start-col (struct-find-start row root-col adj))
(end-col (+ start-col newadj (length atom-string))))
(cond ((< end-col *sdraw-horizontal-atom-cutoff*)
(struct-record-position row end-col)
(list 'atom row (+ start-col newadj) atom-string circ-string))
(t (struct-process-etc row root-col adj)))))
(defun struct-label-cons (obj row root-col adj)
(assign-label obj)
(let* ((string (format nil "#~S=" *circ-label-counter*))
(newadj (struct-find-adj row root-col adj (length string)))
(cons-start (struct-find-start row root-col adj))
(car-structure
(struct1 (car obj)
(+ row *inter-cons-v-arrow-length*)
cons-start newadj t))
(start-col (third car-structure)))
(if (>= start-col *sdraw-horizontal-cons-cutoff*)
(struct-process-etc row root-col adj)
(progn
(struct-record-position row (- (+ start-col
*cons-atom-h-arrow-length*)
adj *inter-atom-h-spacing*))
(list 'cons row start-col car-structure
(struct1 (cdr obj) row
(+ start-col *cons-atom-h-arrow-length*) 0 t)
string)))))
(defun assign-label (obj)
(setf (gethash obj *circ-hash-table*)
(incf *circ-label-counter*)))
;;; Handle circular references by displaying them as #n#.
;;; When called on the first pass, this function always uses a label of 0.
;;; It will get the label right on the second pass.
(defun struct-process-circ-reference (obj row root-col adj)
(let ((start-col (struct-find-start row root-col adj))
(string (format nil "#~S#" (gethash obj *circ-hash-table*))))
(struct-record-position
row
(+ (+ start-col adj) (length string)))
(list 'msg row (+ start-col adj) string)))
;;; Support functions.
(defun struct-find-start (row root-col adj)
(max root-col
(- (+ *inter-atom-h-spacing* (aref *line-endings* row)) adj)))
(defun struct-find-adj (row col adj size)
(let* ((line-end (max 0 (+ *inter-atom-h-spacing*
(aref *line-endings* row))))
(newadj (- line-end (- col (max size adj)))))
(max adj (min (max newadj 0) size))))
(defun struct-record-position (row end-col)
(setf (aref *line-endings* row) end-col))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW-LOOP and subordinate definitions.
(defparameter *sdraw-loop-prompt-string* "S> ")
(defun sdraw-loop ()
"Read-eval-print loop using sdraw to display results."
(format t "~&Type any Lisp expression, or (ABORT) to exit.~%~%")
(sdl1))
(defun sdl1 ()
(loop
(format t "~&~A" *sdraw-loop-prompt-string*)
(let ((form (read)))
(setf +++ ++
++ +
+ -
- form)
(if (eq form :abort) (return-from sdl1))
(let ((result (eval form)))
(setf /// //
// /
/ (list result)
*** **
** *
* result)
(display-sdl-result *)))))
(defun display-sdl-result (result)
(sdraw result)
(let* ((*print-circle* (if (boundp '*sdraw-print-circle*)
*sdraw-print-circle*
*print-circle*))
(*print-length* nil)
(*print-level* nil)
(*print-pretty* #+cmu t #-cmu nil)
(full-text (format nil "Result: ~S" result))
(text (if (> (length full-text)
*sdraw-display-width*)
(concatenate 'string
(subseq full-text 0 (- *sdraw-display-width* 4))
"...)")
full-text)))
(if (consp result)
(format t "~%~A~%" text))
(terpri)))
(defun display-sdl-error (error)
(format t "~A~%~%" error))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SCRAWL and subordinate definitions.
(defparameter *scrawl-prompt-string* "SCRAWL> ")
(defvar *scrawl-object* nil)
(defvar *scrawl-current-obj*)
(defvar *extracting-sequence* nil)
(defun scrawl (obj)
"Read-eval-print loop to travel through list"
(format t "~&Crawl through list: 'H' for help, 'Q' to quit.~%~%")
(setf *scrawl-object* obj)
(scrawl-start-cmd)
(scrawl1))
(defun scrawl1 ()
(loop
(format t "~&~A" *scrawl-prompt-string*)
(let ((command (read-uppercase-char)))
(case command
(#\A (scrawl-car-cmd))
(#\D (scrawl-cdr-cmd))
(#\B (scrawl-back-up-cmd))
(#\S (scrawl-start-cmd))
(#\H (display-scrawl-help))
(#\Q (return))
(t (display-scrawl-error))))))
(defun scrawl-car-cmd ()
(cond ((consp *scrawl-current-obj*)
(push 'car *extracting-sequence*)
(setf *scrawl-current-obj* (car *scrawl-current-obj*)))
(t (format t
"~&Can't take CAR or CDR of an atom. Use B to back up.~%")))
(display-scrawl-result))
(defun scrawl-cdr-cmd ()
(cond ((consp *scrawl-current-obj*)
(push 'cdr *extracting-sequence*)
(setf *scrawl-current-obj* (cdr *scrawl-current-obj*)))
(t (format t
"~&Can't take CAR or CDR of an atom. Use B to back up.~%")))
(display-scrawl-result))
(defun scrawl-back-up-cmd ()
(cond (*extracting-sequence*
(pop *extracting-sequence*)
(setf *scrawl-current-obj*
(extract-obj *extracting-sequence* *scrawl-object*)))
(t (format t "~&Already at beginning of object.")))
(display-scrawl-result))
(defun scrawl-start-cmd ()
(setf *scrawl-current-obj* *scrawl-object*)
(setf *extracting-sequence* nil)
(display-scrawl-result))
(defun extract-obj (seq obj)
(reduce #'funcall
seq
:initial-value obj
:from-end t))
(defun get-car/cdr-string ()
(if (null *extracting-sequence*)
(format nil "'~S" *scrawl-object*)
(format nil "(c~Ar '~S)"
(map 'string #'(lambda (x)
(ecase x
(car #\a)
(cdr #\d)))
*extracting-sequence*)
*scrawl-object*)))
(defun display-scrawl-result (&aux (*print-length* nil)
(*print-level* nil)
(*print-pretty* #+cmu t #-cmu nil)
(*print-circle* t))
(let* ((extract-string (get-car/cdr-string))
(text (if (> (length extract-string) *sdraw-display-width*)
(concatenate 'string
(subseq extract-string 0
(- *sdraw-display-width* 4))
"...)")
extract-string)))
(sdraw *scrawl-current-obj*)
(format t "~&~%~A~%~%" text)))
(defun display-scrawl-help ()
(format t "~&Legal commands: A)car D)cdr B)back up~%")
(format t "~& S)start Q)quit H)help~%"))
(defun display-scrawl-error ()
(format t "~&Illegal command.~%")
(display-scrawl-help))
(defun read-uppercase-char ()
(let ((response (read-line)))
(and (plusp (length response))
(char-upcase (char response 0)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The following definitions are specific to the tty implementation.
(defparameter *cons-string* "[*|*]")
(defparameter *cons-cell-flatsize* 5.)
(defparameter *cons-h-arrowshaft-char* #\-)
(defparameter *cons-h-arrowhead-char* #\>)
(defparameter *cons-v-line* "|")
(defparameter *cons-v-arrowhead* "v")
(defvar *textline-array* (make-array *sdraw-num-lines*))
(defvar *textline-lengths* (make-array *sdraw-num-lines*))
(eval-when (eval load)
(dotimes (i *sdraw-num-lines*)
(setf (aref *textline-array* i)
(make-array *sdraw-display-width*
:element-type 'string-char))))
(defun char-blt (row start-col string)
(let ((spos (aref *textline-lengths* row))
(line (aref *textline-array* row)))
(do ((i spos (1+ i)))
((>= i start-col))
(setf (aref line i) #\Space))
(replace line string :start1 start-col)
(setf (aref *textline-lengths* row)
(+ start-col (length string)))))
(defun draw-structure (directions)
(fill *textline-lengths* 0.)
(when *sdraw-leading-arrow* (draw-leading-arrow))
(follow-directions directions)
(dump-display))
(defun draw-leading-arrow ()
(do ((i 0 (1+ i)))
((>= (1+ i) *leading-arrow-length*)
(char-blt 0 i (string *cons-h-arrowhead-char*)))
(char-blt 0 i (string *cons-h-arrowshaft-char*))))
(defun follow-directions (dirs &optional is-car)
(ecase (car dirs)
(cons (draw-cons dirs))
((atom msg) (draw-msg dirs is-car))))
(defun draw-cons (obj)
(let* ((row (second obj))
(col (third obj))
(car-component (fourth obj))
(cdr-component (fifth obj))
(string (sixth obj))
(line (aref *textline-array* row))
(h-arrow-start (+ col *cons-cell-flatsize*))
(h-arrowhead-col (1- (third cdr-component)))
(cdr-string? (if (eq 'cons (first cdr-component))
(sixth cdr-component)
(fifth cdr-component))))
(if cdr-string? (decf h-arrowhead-col (length cdr-string?)))
(char-blt row (- col (length string))
(if string (concatenate 'string string *cons-string*)
*cons-string*))
(do ((i h-arrow-start (1+ i)))
((>= i h-arrowhead-col))
(setf (aref line i) *cons-h-arrowshaft-char*))
(setf (aref line h-arrowhead-col) *cons-h-arrowhead-char*)
(setf (aref *textline-lengths* row) (1+ h-arrowhead-col))
(char-blt (+ row 1) (+ col 1) *cons-v-line*)
(char-blt (+ row 2) (+ col 1) *cons-v-arrowhead*)
(follow-directions car-component t)
(follow-directions cdr-component)))
(defun draw-msg (obj is-car)
(let* ((row (second obj))
(col (third obj))
(string (fourth obj))
(circ-string (fifth obj)))
(if circ-string (setf string (concatenate 'string circ-string string)))
(char-blt row
(+ (- col (length circ-string))
(if (and is-car
(<= (length string)
*cons-v-arrow-offset-threshold*))
*cons-v-arrow-offset-value*
0))
string)))
(defun dump-display ()
(terpri)
(dotimes (i *sdraw-num-lines*)
(let ((len (aref *textline-lengths* i)))
(if (plusp len)
(format t "~&~A"
(subseq (aref *textline-array* i) 0 len))
(return nil))))
(terpri))
发表评论