Patch to cons-to-ascii initialize-instance to aid subclassing.
Patch to cons-to-ascii initialize-instance.
*** cons-to-ascii.lisp.orig 2019-04-18 00:54:49.114582525 +0200
--- cons-to-ascii.lisp 2019-04-18 00:55:37.970582422 +0200
***************
*** 205,212 ****
;; @---+---+
;; | * |NIL| @ = (0,0)
;; +---+---+
(frame-rect pict x (- y 2) 5 3)
! (frame-rect pict (+ x 4) (- y 2) 5 3)
(draw-string pict (+ x 1) (1- y) (if (car cell) " * " "NIL"))
(draw-string pict (+ x 5) (1- y) (if (cdr cell) " * " "NIL"))
pict) ;;DRAW-CONS
--- 205,217 ----
;; @---+---+
;; | * |NIL| @ = (0,0)
;; +---+---+
+ #+NIL
+ (progn
(frame-rect pict x (- y 2) 5 3)
! (frame-rect pict (+ x 4) (- y 2) 5 3))
! (progn
! (frame-rect pict x (- y 2) 4.5 3)
! (frame-rect pict (+ x 4.5) (- y 2) 4.5 3))
(draw-string pict (+ x 1) (1- y) (if (car cell) " * " "NIL"))
(draw-string pict (+ x 5) (1- y) (if (cdr cell) " * " "NIL"))
pict) ;;DRAW-CONS
***************
*** 252,257 ****
--- 257,281 ----
(car-deco dec)))
) ;;DRAW-DECORATED-CELL
+ (defclass clim-picture (picture)
+ ((stream :initarg :stream :initform nil :accessor clim-picture-stream)))
+
+ (defmethod frame-rect ((pict clim-picture)
+ x y w h &key top-left top-right bottom-left bottom-right top bottom left right)
+ (with-slots (stream) pict
+ (cond ((= w 0))
+ (t
+ (clim:draw-rectangle* stream x y (+ x w) (+ y h) :filled nil)))))
+
+ (defmethod draw-arrow ((pict clim-picture) x y w h &key tail)
+ (with-slots (stream) pict
+ (when (= w 0) (incf y) (decf h))
+ (when (= h 0) (incf w))
+ (clim:draw-arrow* stream x y (+ x w) (+ y h) :head-length 8/8 :head-width 6/8)))
+
+ (defmethod draw-string ((pict clim-picture) x y string &key direction)
+ (with-slots (stream) pict
+ (clim:draw-text* stream string x y)))
(defun draw-list (list &key (title (format nil "~(~S~)" list)))
"
***************
*** 302,315 ****
(pic))
(multiple-value-setq (tw th) (size-string +picture-instance+ title))
(setf th (abs th))
! (setf pic (make-instance 'picture
:width (+ 4 (max tw (w dec)))
:height (+ 4 th (h dec))))
(frame-rect pic 0 0 (width pic) (height pic))
(when title
(draw-string pic 2 (- (height pic) 2) title))
(draw-decorated-cell pic 2 (- (height pic) 4 th) dec)
! pic)) ;;DRAW-LIST
(defun transpose-tree (tree)
--- 326,344 ----
(pic))
(multiple-value-setq (tw th) (size-string +picture-instance+ title))
(setf th (abs th))
! (clim:with-room-for-graphics (*standard-output*)
! (clim:with-scaling (*standard-output* 8 -12)
! (setf pic (make-instance 'clim-picture
! :stream *standard-output*
:width (+ 4 (max tw (w dec)))
:height (+ 4 th (h dec))))
+ (setf (slot-value pic 'stream) *standard-output*)
(frame-rect pic 0 0 (width pic) (height pic))
(when title
(draw-string pic 2 (- (height pic) 2) title))
(draw-decorated-cell pic 2 (- (height pic) 4 th) dec)
! pic
! (values))))) ;;DRAW-LIST
(defun transpose-tree (tree)