From e52775d3fa28442de2fb11f155486651c57aca83 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Wed, 1 Jul 1992 16:08:06 +0000
Subject: [PATCH] Initial revision

---
 clx/clx-prefill.lisp       | 294 ++++++++++++++++++++
 demo/ico.lisp              | 544 +++++++++++++++++++++++++++++++++++++
 genera/genera-prefill.lisp | 303 +++++++++++++++++++++
 3 files changed, 1141 insertions(+)
 create mode 100644 clx/clx-prefill.lisp
 create mode 100644 demo/ico.lisp
 create mode 100644 genera/genera-prefill.lisp

diff --git a/clx/clx-prefill.lisp b/clx/clx-prefill.lisp
new file mode 100644
index 00000000..b24cc0d2
--- /dev/null
+++ b/clx/clx-prefill.lisp
@@ -0,0 +1,294 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+
+;;; (generate-prefill-dispatch-caches 'design)
+
+(prefill-dispatch-caches
+  (clx-clim::clx-decode-color
+    (gray-color t)
+    (flipping-ink t)
+    (rgb-color t)
+    (standard-opacity t))
+  (clx-clim::clx-decode-ink
+    (gray-color t)
+    (flipping-ink t)
+    (rgb-color t)
+    (contrasting-ink t)
+    (rectangular-tile t)
+    (pattern t))
+  (clx-clim::clx-decode-pattern
+    (pattern t)))
+
+
+;;; (generate-prefill-dispatch-caches 'medium)
+
+(prefill-dispatch-caches)
+
+
+;;; (generate-prefill-dispatch-caches 'port)
+
+(prefill-dispatch-caches
+  (clx-clim::initialize-clx-port))
+
+
+;;; (generate-prefill-dispatch-caches 'application-frame)
+
+(prefill-dispatch-caches
+  (frame-wrapper
+    (clx-clim::clx-frame-manager menu-frame t)
+    (clx-clim::clx-frame-manager accept-values-own-window t))
+  (generate-panes
+    (clx-clim::clx-frame-manager menu-frame)
+    (clx-clim::clx-frame-manager accept-values)
+    (clx-clim::clx-frame-manager accept-values-own-window))
+  (note-frame-disabled
+    (clx-clim::clx-frame-manager menu-frame)
+    (clx-clim::clx-frame-manager accept-values-own-window))
+  (note-frame-enabled
+    (clx-clim::clx-frame-manager menu-frame)
+    (clx-clim::clx-frame-manager accept-values-own-window)))
+
+
+;;; (generate-prefill-dispatch-caches 'frame-manager)
+
+(prefill-dispatch-caches
+  (adopt-frame
+    (clx-clim::clx-frame-manager t))
+  (frame-manager-dialog-view
+    (clx-clim::clx-frame-manager))
+  (frame-manager-display-pointer-documentation
+    (clx-clim::clx-frame-manager t t t t t t t))
+  ((setf frame-manager-frames)
+   (t clx-clim::clx-frame-manager))
+  (frame-manager-menu-choose
+    (clx-clim::clx-frame-manager t))
+  (graft
+    (clx-clim::clx-frame-manager))
+  (make-pane-1
+    (clx-clim::clx-frame-manager t t))
+  (make-pane-class
+    (clx-clim::clx-frame-manager t))
+  (make-pane-arglist
+    (clx-clim::clx-frame-manager t))
+  (port
+    (clx-clim::clx-frame-manager))
+  (print-object
+    (clx-clim::clx-frame-manager t))
+  #+Genera (clos-internals::print-self
+	     (clx-clim::clx-frame-manager t t t))
+  (update-frame-settings
+    (clx-clim::clx-frame-manager t))
+  #+Genera (clos-internals::which-operations
+	     (clx-clim::clx-frame-manager)))
+
+
+;;; (generate-prefill-dispatch-caches 'clx-clim::clx-medium)
+
+(prefill-dispatch-caches
+  (degraft-medium
+    (clx-clim::clx-medium clx-clim::clx-port t))
+  (engraft-medium
+    (clx-clim::clx-medium clx-clim::clx-port vbox-pane)
+    (clx-clim::clx-medium clx-clim::clx-port outlined-pane)
+    (clx-clim::clx-medium clx-clim::clx-port scroller-pane)
+    (clx-clim::clx-medium clx-clim::clx-port table-pane)
+    (clx-clim::clx-medium clx-clim::clx-port scroll-bar-pane)
+    (clx-clim::clx-medium clx-clim::clx-port spacing-pane)
+    (clx-clim::clx-medium clx-clim::clx-port hbox-pane)
+    (clx-clim::clx-medium clx-clim::clx-port scroll-bar-target-pane)
+    (clx-clim::clx-medium clx-clim::clx-port scroll-bar-shaft-pane)
+    (clx-clim::clx-medium clx-clim::clx-port viewport)
+    (clx-clim::clx-medium clx-clim::clx-port interactor-pane)
+    (clx-clim::clx-medium clx-clim::clx-port slider-pane)
+    (clx-clim::clx-medium clx-clim::clx-port radio-box-pane)
+    (clx-clim::clx-medium clx-clim::clx-port toggle-button-pane)
+    (clx-clim::clx-medium clx-clim::clx-port push-button-pane)
+    (clx-clim::clx-medium clx-clim::clx-port command-menu-pane)
+    (clx-clim::clx-medium clx-clim::clx-port application-pane)
+    (clx-clim::clx-medium clx-clim::clx-port clim-stream-pane)
+    (clx-clim::clx-medium clx-clim::clx-port top-level-sheet))
+  (invoke-with-drawing-options
+    (clx-clim::clx-medium t))
+  (invoke-with-text-style
+    (clx-clim::clx-medium t t t))
+  (medium-force-output
+    (clx-clim::clx-medium))
+  (medium-beep
+    (clx-clim::clx-medium))
+  (medium-+y-upward-p
+    (clx-clim::clx-medium))
+  ((setf medium-+y-upward-p)
+    (t clx-clim::clx-medium))
+  (medium-background
+    (clx-clim::clx-medium))
+  (medium-default-text-style
+    (clx-clim::clx-medium))
+  (medium-draw-ellipse*
+    (clx-clim::clx-medium t t t t t t t t t))
+  (medium-draw-line*
+    (clx-clim::clx-medium t t t t))
+  (medium-draw-polygon*
+    (clx-clim::clx-medium t t t))
+  (medium-draw-rectangle*
+    (clx-clim::clx-medium t t t t t))
+  (medium-draw-text*
+    (clx-clim::clx-medium t t t t t t t t t t))
+  (medium-copy-area
+    (clx-clim::clx-medium t t t t clx-clim::clx-medium t t))
+  (medium-foreground
+    (clx-clim::clx-medium))
+  (medium-ink
+    (clx-clim::clx-medium))
+  ((setf medium-ink)
+    (t clx-clim::clx-medium))
+  (medium-line-style
+    (clx-clim::clx-medium))
+  ((setf medium-line-style)
+    (t clx-clim::clx-medium))
+  (medium-merged-text-style
+    (clx-clim::clx-medium))
+  (medium-text-style
+    (clx-clim::clx-medium))
+  (medium-transformation
+    (clx-clim::clx-medium))
+  ((setf medium-transformation)
+    (t clx-clim::clx-medium))
+  #+Genera (clos-internals:operation-handled-p
+	     (clx-clim::clx-medium t))
+  (port
+    (clx-clim::clx-medium))
+  (print-object
+    (clx-clim::clx-medium t))
+  #+Genera (clos-internals::print-self
+	     (clx-clim::clx-medium t t t))
+  #+Genera (clos-internals::send-if-handles
+	     (clx-clim::clx-medium t))
+  (stream-string-output-size
+    (clx-clim::clx-medium t))
+  (stream-string-width
+    (clx-clim::clx-medium t))
+  (text-style-ascent
+    (standard-text-style clx-clim::clx-medium))
+  (text-style-descent
+    (standard-text-style clx-clim::clx-medium))
+  (text-style-height
+    (standard-text-style clx-clim::clx-medium))
+  (text-style-width
+    (standard-text-style clx-clim::clx-medium))
+  (text-size
+    (clx-clim::clx-medium t))
+  #+Genera (clos-internals::which-operations
+	     (clx-clim::clx-medium)))
+
+
+;;; (generate-prefill-dispatch-caches 'clx-clim::clx-port)
+
+(prefill-dispatch-caches
+  (degraft-medium)
+  (disable-mirror
+    (clx-clim::clx-port t))
+  (distribute-event
+    (clx-clim::clx-port t))
+  (distribute-event-1
+    (clx-clim::clx-port pointer-button-release-event)
+    (clx-clim::clx-port pointer-button-press-event)
+    (clx-clim::clx-port key-press-event)
+    (clx-clim::clx-port key-release-event)
+    (clx-clim::clx-port pointer-motion-event))
+  (enable-mirror
+    (clx-clim::clx-port t))
+  (engraft-medium)
+  (clx-clim::initialize-clx-port
+    (clx-clim::clx-port))
+  (initialize-menu
+    (clx-clim::clx-port clim-stream-pane t))
+  (make-frame-manager
+    (clx-clim::clx-port))
+  (make-medium
+    (clx-clim::clx-port t))
+  (mirror-inside-edges*
+    (clx-clim::clx-port t))
+  (mirror-native-edges*
+    (clx-clim::clx-port t))
+  (mirror-region
+    (clx-clim::clx-port t))
+  (mirror-region*
+    (clx-clim::clx-port t))
+  (mirror-region-updated
+    (clx-clim::clx-port top-level-sheet))
+  #+Genera (clos-internals:operation-handled-p
+	     (clx-clim::clx-port t))
+  ((setf port)
+    (clx-clim::clx-port t))
+  (port-event-loop
+    (clx-clim::clx-port))
+  (port-glyph-for-character
+    (clx-clim::clx-port t t))
+  (port-graft-class
+    (clx-clim::clx-port))
+  (port-grafts
+    (clx-clim::clx-port))
+  ((setf port-grafts)
+    (t clx-clim::clx-port))
+  ((setf port-keyboard-input-focus)
+    (t clx-clim::clx-port))
+  (port-note-cursor-change
+    (clx-clim::clx-port t t (eql 'cursor-focus) t t)
+    (clx-clim::clx-port t t (eql 'cursor-active) t t)
+    (clx-clim::clx-port t t (eql 'cursor-state) t t))
+  (port-pointer
+    (clx-clim::clx-port))
+  ((setf port-pointer)
+    (t clx-clim::clx-port))
+  ((setf port-process)
+    (t clx-clim::clx-port))
+  (port-server-path
+    (clx-clim::clx-port))
+  (medium-text-bounding-box
+    (clx-clim::clx-medium t t t t t t t t t t t t))
+  (port-trace-thing
+    (clx-clim::clx-port))
+  (port-type
+    (clx-clim::clx-port))
+  (print-object
+    (clx-clim::clx-port t))
+  #+Genera (clos-internals::print-self
+	     (clx-clim::clx-port t t t))
+  (process-next-event
+    (clx-clim::clx-port))
+  (realize-graft
+    (clx-clim::clx-port t))
+  (realize-mirror
+    (clx-clim::clx-port top-level-sheet))
+  (restart-port
+    (clx-clim::clx-port))
+  #+Genera (clos-internals::send-if-handles
+	     (clx-clim::clx-port t))
+  (set-sheet-mirror-edges*
+    (clx-clim::clx-port t t t t t))
+  (shared-initialize
+    (clx-clim::clx-port t))
+  (standardize-text-style
+    (clx-clim::clx-port t))
+  (text-style-mapping
+    (clx-clim::clx-port standard-text-style))
+  ((setf text-style-mapping)
+    (t clx-clim::clx-port t))
+  (text-style-mapping*
+    (clx-clim::clx-port t))
+  (update-mirror-region
+    (clx-clim::clx-port top-level-sheet))
+  (update-mirror-region-1
+    (clx-clim::clx-port t t))
+  (update-mirror-transformation
+    (clx-clim::clx-port top-level-sheet)
+    (clx-clim::clx-port standard-graft))
+  (update-mirror-transformation-1
+    (clx-clim::clx-port t t))
+  #+Genera (clos-internals::which-operations
+	     (clx-clim::clx-port)))
+
diff --git a/demo/ico.lisp b/demo/ico.lisp
new file mode 100644
index 00000000..789a7485
--- /dev/null
+++ b/demo/ico.lisp
@@ -0,0 +1,544 @@
+;;; -*- Mode: Lisp; Package: clim-user ; Base: 10.; Syntax: Common-Lisp -*-
+;;;
+;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
+;;; Portions (c) 1992 Franz Inc.
+;;; $fiHeader$
+;;; Algorithm pretty much lifted from X11 demo program.
+;;;
+
+(in-package :clim-user)
+
+;;;
+;;; Entry 
+;;;
+
+(defvar *ico-mode* :clim)
+
+(defun ico ()
+  (run-frame-top-level (make-application-frame 'ico-frame)))
+
+;;;
+;;; ICO Frames
+;;;
+
+(define-application-frame ico-frame ()
+			  ((ico-time-p :initform t)
+			   (ico-line-style :initform :thin)
+			   (draw-edges :initform t)
+			   (draw-faces :initform t)
+			   (ico-process :initform nil :accessor ico-process))
+  (:command-table (ico-frame :inherit-from (clim-internals::accept-values-pane)))
+  (:panes
+   (target :application :width 400 :height 400)
+   (options :application
+    :width :compute :height :compute
+    :display-function `(clim-internals::accept-values-pane-displayer
+			:displayer display-options-pane)))
+  (:layouts (:default (vertically () target options))))
+
+(defmethod frame-target ((fr ico-frame))
+  (get-frame-pane fr 'target))
+
+
+(defmethod display-options-pane ((frame ico-frame) pane &key max-width max-height)
+  (declare (ignore max-width max-height))
+  (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame
+    (setf ico-time-p (accept 'boolean 
+			     :default ico-time-p
+			     :stream pane
+			     :prompt "Time"))
+    (terpri pane)
+    (let ((x (append (and draw-faces '(:faces))
+		     (and draw-edges '(:edges)))))
+      (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
+      (terpri pane)
+      (setf draw-edges (member :edges x)
+	    draw-faces (member :faces x)))
+    (setf ico-line-style (accept '(member :thin :thick)
+				 :default ico-line-style
+				 :stream pane
+				 :prompt "Line Style"))
+    (terpri pane)))
+
+(define-ico-frame-command (com-ico-throw-ball :menu t)
+    ()
+  (with-application-frame (frame)
+    (throw-ball frame)))
+
+(define-ico-frame-command (com-ico-catch-ball :menu t)
+    ()
+  (with-application-frame (frame)
+    (catch-ball frame)))
+
+
+
+(defmethod disable-frame :after ((frame ico-frame))
+  (catch-ball frame))
+
+(defmethod throw-ball ((frame ico-frame))
+  (unless (ico-process frame)
+    (setf (ico-process frame)
+	  (clim-sys:make-process #'(lambda ()
+			    (if (slot-value frame 'ico-time-p)
+				(time (run-ico frame))
+				(run-ico frame))
+			    (setf (ico-process frame) nil))
+			:name "ICO ball process"))))
+
+(defmethod catch-ball ((frame ico-frame))
+  (when (ico-process frame)
+    (clim-sys::destroy-process (ico-process frame))
+    (setf (ico-process frame) nil)))
+
+(defmethod repaint-frame ((frame ico-frame) pane region)
+  (declare (ignore pane region))
+  (throw-ball frame))
+
+;;;
+;;; Ico, the stuff
+;;;
+
+(defconstant ico-w   150)
+(defconstant ico-h   150)
+(defconstant ico-w/2 (floor ico-w 2))
+(defconstant ico-h/2 (floor ico-h 2))
+
+(defun run-ico (frame &optional (count 1000000))
+  (let* ((pane  (frame-target frame))
+	 (medium (sheet-medium pane))
+	 (fg (medium-foreground medium))
+	 (bg (medium-background medium))
+	 (win-w (bounding-rectangle-width pane))
+	 (win-h (bounding-rectangle-height pane))
+	 (ico-x (floor (* (- win-w ico-w) 128)
+		       256))
+	 (ico-y (floor (* (- win-h ico-h) 128)
+		       256))
+	 (ico-dx 13)
+	 (ico-dy 9)
+	 (xtop (- win-w ico-w))
+	 (ytop (- win-h ico-h))
+	 (prev-x 0)
+	 (prev-y 0)
+	 edges
+	 face-list
+	 display black white drawable gcontext)
+    (declare (integer win-w win-h)
+	     (integer ico-x ico-y ico-dx ico-dy xtop ytop prev-x prev-y)
+	     (special prev-x prev-y))
+    
+    (with-slots (draw-faces draw-edges) frame
+      (ecase *ico-mode*
+	#+ABC
+	(:abc (clear-region medium +everywhere+))
+	#+CLIM
+	(:clim)
+	(:dont)
+	#+XLIB-IGNORE
+	(:clx
+	 (setq display (on-x::x-display (port medium)))
+	 (setq black (xlib:screen-black-pixel (on-x::x-screen (port medium))))
+	 (setq white (xlib:screen-white-pixel (on-x::x-screen (port medium))))
+	 (setq drawable (slot-value medium 'on-x::drawable))
+	 (setq gcontext (slot-value medium 'on-x::gcontext))
+	 (setf (xlib:gcontext-fill-style gcontext) :solid))
+	#+Genera
+	(:genera
+	 (setq drawable (slot-value medium 'on-genera::drawable))))
+
+      (window-clear pane)
+      (dotimes (i count)
+      
+	#+ignore
+	(cond (draw-edges
+	       (do* ((minx (car edges))
+		     (miny (cadr edges))
+		     (maxx minx)
+		     (maxy miny)
+		     (edges  (cddr edges)  (cddr edges)))
+		   ((null edges)
+		    (when (and minx miny maxx maxy)
+		      (draw-rectangle* medium 
+				       (1- minx)
+				       (1- miny)
+				       (1+ maxx)
+				       (1+ maxy)
+				       :ink bg
+				       :filled t)))
+		 (let ((x (car edges))
+		       (y (second edges)))
+		   (clim-utils::minf minx x)
+		   (clim-utils::minf miny y)
+		   (clim-utils::maxf maxx x)
+		   (clim-utils::maxf maxy y)))))
+      
+	(multiple-value-setq (edges face-list)
+	  (calculate-ico ico-x ico-y draw-edges draw-faces edges face-list))
+      
+      
+	;; Draw ICO
+	(ecase *ico-mode*
+	  #+CLIM
+	  (:clim
+
+	   #-ignore
+	   (draw-rectangle* medium 0 0 win-w win-h :ink bg :filled t)
+	   
+	   #+ignore
+	   (draw-rectangle* medium 
+			    (- prev-x (1+ ico-w) 30) 
+			    (- prev-y (1+ ico-h) 30)
+			    (+ (+ prev-x (1+ ico-w)) 30)
+			    (+ (+ prev-y (1+ ico-h)) 30)
+			    :ink bg 
+			    :filled t)
+	   (when draw-edges
+	     (draw-lines* medium edges :ink +black+
+			  :line-thickness 
+			  (ecase (slot-value frame 'ico-line-style)
+			    (:thick 5)
+			    (:thin nil))))
+	   (when draw-faces
+	     (do ((f face-list (cdr (cdddr (cdddr f)))))
+		 ((null f))
+	       (draw-polygon* medium (subseq f 1 7)
+			      :closed t
+			      :filled t
+			      :ink (if (oddp (car f)) +red+ +green+))))
+	 
+	   (silica::medium-force-output medium))
+	
+	  #+XLIB-IGNORE
+	  (:clx 
+	   (setf (xlib:gcontext-foreground gcontext) white)
+	   (xlib:draw-rectangle drawable gcontext prev-x prev-y 
+				(1+ ico-w) (1+ ico-h) t)
+	   (setf (xlib:gcontext-foreground gcontext) black)
+	   (xlib:draw-segments drawable gcontext
+			       (mapcan
+				#'(lambda (point)
+				    (list (round (ico-point-x point)) 
+					  (round (ico-point-y point))))
+				edges))
+	   (xlib:display-force-output display))
+	  #+Genera
+	  (:genera
+	   (scl:send drawable :draw-rectangle
+		     (1+ ico-w) (1+ ico-h)
+		     prev-x prev-y
+		     :erase)
+	   (apply #'scl:send drawable :draw-lines :draw
+		  (mapcan
+		   #'(lambda (point)
+		       (list (round (ico-point-x point)) 
+			     (round (ico-point-y point))))
+		   edges)))
+	  (:dont))
+
+	(setq prev-x ico-x
+	      prev-y ico-y)
+	(incf ico-x ico-dx)
+	(when (or (< ico-x 0) (> ico-x xtop))
+	  (decf ico-x (* ico-dx 2))
+	  (setq ico-dx (- ico-dx)))
+	(incf ico-y ico-dy)
+	(when (or (< ico-y 0) (> ico-y ytop))
+	  (decf ico-y (* ico-dy 2))
+	  (setq ico-dy (- ico-dy)))))))
+
+
+
+
+;;;
+;;; DRAW ICO
+;;;
+
+(defconstant nv 12)
+(defconstant nf 20)
+
+(defparameter v3-seq 
+    (let ((x
+	   '(;; Initial Position
+	     (0.0        0.0        -0.9510565)
+	     (0.0        0.8506508  -0.42532536)
+	     (0.809017   0.26286557 -0.42532536)
+	     (0.5       -0.68819094 -0.42532536)
+	     (-0.5      -0.68819094 -0.42532536)
+	     (-0.809017  0.26286557 -0.42532536)
+	     (0.5        0.68819094  0.42532536)
+	     (0.809017  -0.26286557  0.42532536)
+	     (0.0       -0.8506508   0.42532536)
+	     (-0.809017 -0.26286557  0.42532536)
+	     (-0.5       0.68819094  0.42532536)
+	     (0.0        0.0         0.9510565))))
+      (make-array (list (length x) 3) 
+		  :element-type 'single-float
+		  :initial-contents x)))
+
+
+(defparameter faces '((0 2 1)  (0 3 2)  (0 4 3)  (0 5 4)  
+		      (0 1 5)  (1 6 10) (1 2 6)  (2 7 6)
+		      (2 3 7)  (3 8 7)  (3 4 8)  (4 9 8)
+		      (4 5 9)  (5 10 9) (5 1 10) (10 6 11)
+		      (6 7 11) (7 8 11) (8 9 11) (9 10 11)))
+
+(defparameter xform nil) ; Initialized Below
+
+
+(defmacro v2-aref (vertex-number field)
+  (case field
+    ((xy) `(aref v2 ,vertex-number 0))
+    ((z) `(aref v2 ,vertex-number 1))	   
+    (t (error "Bad array reference on v2"))))
+
+
+(defun make-ico-point (x y)
+  (excl::fast
+   (let ((z (make-array 2 :element-type 'single-float)))
+     (declare (type (simple-array single-float (2)) z))
+     (setf (aref z 0) (float x 0s0)
+	   (aref z 1) (float y 0s0))
+     z)))
+
+(defmacro ico-point-x (z) `(the single-float (aref (the (simple-array single-float (2)) ,z) 0)))
+(defmacro ico-point-y (z) `(the single-float (aref (the (simple-array single-float (2)) ,z) 1)))
+
+(defparameter v2 (make-array (list nv 2)
+		       :initial-contents
+		       (clim-utils::with-collection
+			   (dotimes (i nv)
+			     (clim-utils::collect (list (make-ico-point 0 0) 0))))))
+
+(defparameter drawn      (make-array (list nv nv) :initial-element nil))
+(defparameter drawn-fill (make-array (* nv nv) :displaced-to drawn))
+
+(defmacro with-non-consing-collection ((list) &body body)
+  `(let* (($with-collection-result$ (or ,list (list :hohoho-and-b-of-rum)))
+	  ($with-collection-tail$ $with-collection-result$)
+	  $with-collection-rest$)
+     (macrolet
+	 ((collect (form)
+	    ;;  The FORM is evaluated first so that COLLECT nests
+	    ;; properly, i.e., The test to determine if this is
+	    ;; the first value collected should be done after the
+	    ;; value itself is generated in case it does
+	    ;; collection as well.
+	    `(let (($collectable$ ,form))
+	       (if $with-collection-tail$
+		   (progn
+		     (setf (car $with-collection-tail$) $collectable$)
+		     (setq $with-collection-tail$ 
+			   (cdr $with-collection-tail$)))
+		   (push $collectable$ $with-collection-rest$))
+	       $collectable$)))
+       ,@body 
+       (unless (eq (car $with-collection-result$) :hohoho-and-b-of-rum)
+	 (if $with-collection-rest$
+	     (nconc $with-collection-result$ (nreverse $with-collection-rest$))
+	     $with-collection-result$)))))
+
+(defun calculate-ico (ico-x ico-y do-edges do-faces edge-point-list face-point-list)
+  (declare (integer ico-x ico-y)
+	   (optimize (safety 0) (speed 3)))
+  (let ((v2-fill (cdr (excl::ah_data v2)))
+	(v3-seq v3-seq)
+	(v2 v2)
+	(drawn drawn)
+	(fp 0)
+	p0 p1 p2)
+    (declare 
+     (type (simple-array single-float (12 3)) v3-seq)
+     (type (simple-array t (12 2)) v2)
+     (type (simple-array t (12 12)) drawn)
+     (simple-vector v2-fill))
+    
+    ;;Clear the drawn array
+    (fill (cdr (excl::ah_data drawn-fill)) nil)
+    
+
+    ;; Rotate vertices
+    (partial-nonhom-transformation xform v3-seq)
+    
+    ;; Convert 3d coordinates to 2D positions
+    (dotimes (i (array-dimension v3-seq 0))
+      (let ((z (aref v2-fill fp))
+	    (x (+ ico-x (* ico-w/2 (+ (aref v3-seq i 0) 1.0))))
+	    (y (+ ico-y (* ico-h/2 (+ (aref v3-seq i 1) 1.0)))))
+	(declare (single-float x y))
+	(if z
+	    (setf (ico-point-x z) x (ico-point-y z) y)
+	  (setf  (aref v2-fill fp)
+	    (make-ico-point x y))))
+      (incf fp)
+      ;; Save the z for hidden line removal
+      (setf (aref v2-fill fp) (aref v3-seq i 2))
+      (incf fp))
+            
+    ;; Accummulate edges, w/o duplicates	    
+
+
+    (values
+     (when do-edges
+       (with-non-consing-collection (edge-point-list)
+	 (macrolet ((collect-point (p)
+		      (let ((pp (gensym)))
+			`(let ((,pp ,p))
+			   (collect (ico-point-x ,pp))
+			   (collect (ico-point-y ,pp))))))
+	   (dolist (face faces)
+	     (setq p0 (first face))
+	     (setq p1 (second face))
+	     (setq p2 (third face))
+	      
+	     ;; Unless hidden for some reason if the sum of the
+	     ;; z-coordinates of the faces is < 0 then its hidden???
+
+	     (unless (< (+ (v2-aref p0 z)
+			   (v2-aref p1 z)
+			   (v2-aref p2 z))
+			0.0)
+	       ;; At this point if we are drawing faces then we have
+	       ;; something to do
+	    
+	       ;; Mark for Draw
+	       (unless (aref drawn p0 p1)
+		 (setf (aref drawn p0 p1) t)
+		 (setf (aref drawn p1 p0) t)
+
+		 (collect-point (v2-aref p0 xy))
+		 (collect-point (v2-aref p1 xy)))
+	
+
+	       (unless (aref drawn p1 p2)
+		 (setf (aref drawn p1 p2) t)
+		 (setf (aref drawn p2 p1) t)
+		 (collect-point (v2-aref p1 xy))
+		 (collect-point (v2-aref p2 xy)))
+	  
+
+	       (unless (aref drawn p2 p0)
+		 (setf (aref drawn p2 p0) t)
+		 (setf (aref drawn p0 p2) t)
+		 (collect-point (v2-aref p2 xy))
+		 (collect-point (v2-aref p0 xy))))))))
+
+     (when do-faces
+       (with-non-consing-collection (face-point-list)
+	 (macrolet ((collect-point (p)
+		      (let ((pp (gensym)))
+			`(let ((,pp ,p))
+			   (collect (ico-point-x ,pp))
+			   (collect (ico-point-y ,pp))))))
+	   (let ((i 0))
+	     (dolist (face faces)
+	       (setq p0 (first face))
+	       (setq p1 (second face))
+	       (setq p2 (third face))
+	      
+	       ;; Unless hidden for some reason if the sum of the
+	       ;; z-coordinates of the faces is < 0 then its hidden???
+
+	       (unless (< (+ (v2-aref p0 z)
+			     (v2-aref p1 z)
+			     (v2-aref p2 z))
+			  0.0)
+		 (collect (incf i))
+		 (collect-point (v2-aref p0 xy))
+		 (collect-point (v2-aref p1 xy))
+		 (collect-point (v2-aref p2 xy)))))))))))
+
+
+;;;
+;;; Matrix Operations
+;;;
+
+(deftype transformation-3d nil '(simple-array single-float (4 4)))
+
+(defun concat-mat (l r m)
+  (declare (type transformation-3d l r m))
+  (dolist (i '(0 1 2 3))
+    (dolist (j '(0 1 2 3))
+      (setf (aref m i j)
+	    (+ (* (aref l i 0)
+		  (aref r 0 j))
+	       (* (aref l i 1)
+		  (aref r 1 j))
+	       (* (aref l i 2)
+		  (aref r 2 j))
+	       (* (aref l i 3)
+		  (aref r 3 j))))))
+  m)
+
+(defun format-rotate-mat (axis angle m)
+  (declare (character axis)
+	   (single-float angle)
+	   (type transformation-3d m))
+  (ident-mat m)
+  (let ((s (sin angle))
+	(c (cos angle)))
+    (declare (single-float s c))
+    (case axis
+      (x (setf (aref m 1 1) c)
+	 (setf (aref m 2 2) c)
+	 (setf (aref m 1 2) s)
+	 (setf (aref m 2 1) (- s)))
+      (y (setf (aref m 0 0) c)
+	 (setf (aref m 2 2) c)
+	 (setf (aref m 2 0) s)
+	 (setf (aref m 0 2) (- s)))
+      (z (setf (aref m 0 0) c)
+	 (setf (aref m 1 1) c)
+	 (setf (aref m 0 1) s)
+	 (setf (aref m 1 0) (- s))))))
+
+(defun ident-mat (m)
+  (declare (type transformation-3d m))
+  (dolist (i '(0 1 2 3))
+    (dolist (j '(0 1 2 3))
+      (setf (aref m i j) 0.0))
+    (setf (aref m i i) 1.0))
+  m)
+
+(defun partial-nonhom-transformation (m v3-seq)
+  (declare (type transformation-3d m)
+	   (type (simple-array single-float (12 3)) v3-seq)
+	   (optimize (safety 0) (speed 3)))
+  (let ((m00 (aref m 0 0))
+	(m10 (aref m 1 0))
+	(m20 (aref m 2 0))
+	(m01 (aref m 0 1))
+	(m11 (aref m 1 1))
+	(m21 (aref m 2 1))
+	(m02 (aref m 0 2))
+	(m12 (aref m 1 2))
+	(m22 (aref m 2 2)))
+    (dotimes (i (array-dimension v3-seq 0))
+      (let* ((in-x (aref v3-seq i 0))
+	     (in-y (aref v3-seq i 1))
+	     (in-z (aref v3-seq i 2)))
+	(setf (aref v3-seq i 0) (+ (* in-x m00)
+				   (* in-y m10)
+				   (* in-z m20))
+	      (aref v3-seq i 1) (+ (* in-x m01)
+				   (* in-y m11)
+				   (* in-z m21))
+	      (aref v3-seq i 2) (+ (* in-x m02)
+				   (* in-y m12)
+				   (* in-z m22)))))))
+
+
+(defun create-xform nil 
+  (let ((r1 (create-transformation-3d))
+	(r2 (create-transformation-3d))
+	(r3 (create-transformation-3d)))
+    (format-rotate-mat 'x (/ (* 5 (coerce pi 'single-float)) 180.0) r1)
+    (format-rotate-mat 'y (/ (* 5 (coerce pi 'single-float)) 180.0) r2)
+    (concat-mat r1 r2 r3)
+    r3))
+
+(defun create-transformation-3d nil 
+  (make-array '(4 4) :element-type 'single-float))
+
+(setq xform (create-xform))
+
+
diff --git a/genera/genera-prefill.lisp b/genera/genera-prefill.lisp
new file mode 100644
index 00000000..d1deab53
--- /dev/null
+++ b/genera/genera-prefill.lisp
@@ -0,0 +1,303 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+
+;;; (generate-prefill-dispatch-caches 'design)
+
+(prefill-dispatch-caches
+  (genera-clim::genera-decode-color
+    (gray-color t)
+    (flipping-ink t)
+    (rgb-color t)
+    (standard-opacity t))
+  (genera-clim::genera-decode-ink
+    (gray-color t)
+    (flipping-ink t)
+    (rgb-color t)
+    (contrasting-ink t)
+    (rectangular-tile t)
+    (pattern t))
+  (genera-clim::genera-decode-pattern
+    (pattern t)))
+
+
+;;; (generate-prefill-dispatch-caches 'medium)
+
+(prefill-dispatch-caches
+  (genera-clim::medium-drawing-possible)
+  (genera-clim::with-appropriate-drawing-state))
+
+
+;;; (generate-prefill-dispatch-caches 'port)
+
+(prefill-dispatch-caches
+  (genera-clim::genera-mirror-native-edges*)
+  (genera-clim::initialize-genera-port))
+
+
+;;; (generate-prefill-dispatch-caches 'application-frame)
+
+(prefill-dispatch-caches
+  (frame-wrapper
+    (genera-clim::genera-frame-manager menu-frame t)
+    (genera-clim::genera-frame-manager accept-values-own-window t))
+  (generate-panes
+    (genera-clim::genera-frame-manager menu-frame)
+    (genera-clim::genera-frame-manager accept-values)
+    (genera-clim::genera-frame-manager accept-values-own-window))
+  (note-frame-disabled
+    (genera-clim::genera-frame-manager menu-frame)
+    (genera-clim::genera-frame-manager accept-values-own-window))
+  (note-frame-enabled
+    (genera-clim::genera-frame-manager menu-frame)
+    (genera-clim::genera-frame-manager accept-values-own-window)))
+
+
+;;; (generate-prefill-dispatch-caches 'frame-manager)
+
+(prefill-dispatch-caches
+  (adopt-frame
+    (genera-clim::genera-frame-manager t))
+  (frame-manager-dialog-view
+    (genera-clim::genera-frame-manager))
+  (frame-manager-display-pointer-documentation
+    (genera-clim::genera-frame-manager t t t t t t t))
+  ((setf frame-manager-frames)
+   (t genera-clim::genera-frame-manager))
+  (frame-manager-menu-choose
+    (genera-clim::genera-frame-manager t))
+  (graft
+    (genera-clim::genera-frame-manager))
+  (make-pane-1
+    (genera-clim::genera-frame-manager t t))
+  (make-pane-class
+    (genera-clim::genera-frame-manager t))
+  (make-pane-arglist
+    (genera-clim::genera-frame-manager t))
+  (port
+    (genera-clim::genera-frame-manager))
+  (print-object
+    (genera-clim::genera-frame-manager t))
+  (clos-internals::print-self
+    (genera-clim::genera-frame-manager t t t))
+  (update-frame-settings
+    (genera-clim::genera-frame-manager t))
+  (clos-internals::which-operations
+    (genera-clim::genera-frame-manager)))
+
+
+;;; (generate-prefill-dispatch-caches 'genera-clim::genera-medium)
+
+(prefill-dispatch-caches
+  (degraft-medium
+    (genera-clim::genera-medium genera-clim::genera-port t))
+  (engraft-medium
+    (genera-clim::genera-medium genera-clim::genera-port vbox-pane)
+    (genera-clim::genera-medium genera-clim::genera-port outlined-pane)
+    (genera-clim::genera-medium genera-clim::genera-port scroller-pane)
+    (genera-clim::genera-medium genera-clim::genera-port table-pane)
+    (genera-clim::genera-medium genera-clim::genera-port scroll-bar-pane)
+    (genera-clim::genera-medium genera-clim::genera-port spacing-pane)
+    (genera-clim::genera-medium genera-clim::genera-port hbox-pane)
+    (genera-clim::genera-medium genera-clim::genera-port scroll-bar-target-pane)
+    (genera-clim::genera-medium genera-clim::genera-port scroll-bar-shaft-pane)
+    (genera-clim::genera-medium genera-clim::genera-port viewport)
+    (genera-clim::genera-medium genera-clim::genera-port interactor-pane)
+    (genera-clim::genera-medium genera-clim::genera-port slider-pane)
+    (genera-clim::genera-medium genera-clim::genera-port radio-box-pane)
+    (genera-clim::genera-medium genera-clim::genera-port toggle-button-pane)
+    (genera-clim::genera-medium genera-clim::genera-port push-button-pane)
+    (genera-clim::genera-medium genera-clim::genera-port command-menu-pane)
+    (genera-clim::genera-medium genera-clim::genera-port application-pane)
+    (genera-clim::genera-medium genera-clim::genera-port clim-stream-pane)
+    (genera-clim::genera-medium genera-clim::genera-port top-level-sheet))
+  (invoke-with-drawing-options
+    (genera-clim::genera-medium t))
+  (invoke-with-text-style
+    (genera-clim::genera-medium t t t))
+  (medium-force-output
+    (genera-clim::genera-medium))
+  (medium-beep
+    (genera-clim::genera-medium))
+  (medium-+y-upward-p
+    (genera-clim::genera-medium))
+  ((setf medium-+y-upward-p)
+    (t genera-clim::genera-medium))
+  (medium-background
+    (genera-clim::genera-medium))
+  (medium-default-text-style
+    (genera-clim::genera-medium))
+  (medium-draw-ellipse*
+    (genera-clim::genera-medium t t t t t t t t t))
+  (medium-draw-line*
+    (genera-clim::genera-medium t t t t))
+  (medium-draw-polygon*
+    (genera-clim::genera-medium t t t))
+  (medium-draw-rectangle*
+    (genera-clim::genera-medium t t t t t))
+  (medium-draw-text*
+    (genera-clim::genera-medium t t t t t t t t t t))
+  (medium-copy-area
+    (genera-clim::genera-medium t t t t genera-clim::genera-medium t t))
+  (genera-clim::medium-drawing-possible
+    (genera-clim::genera-medium))
+  (medium-foreground
+    (genera-clim::genera-medium))
+  (medium-ink
+    (genera-clim::genera-medium))
+  ((setf medium-ink)
+    (t genera-clim::genera-medium))
+  (medium-line-style
+    (genera-clim::genera-medium))
+  ((setf medium-line-style)
+    (t genera-clim::genera-medium))
+  (medium-merged-text-style
+    (genera-clim::genera-medium))
+  (medium-text-style
+    (genera-clim::genera-medium))
+  (medium-transformation
+    (genera-clim::genera-medium))
+  ((setf medium-transformation)
+    (t genera-clim::genera-medium))
+  (clos-internals:operation-handled-p
+    (genera-clim::genera-medium t))
+  (port
+    (genera-clim::genera-medium))
+  (print-object
+    (genera-clim::genera-medium t))
+  (clos-internals::print-self
+    (genera-clim::genera-medium t t t))
+  (clos-internals::send-if-handles
+    (genera-clim::genera-medium t))
+  (stream-string-output-size
+    (genera-clim::genera-medium t))
+  (stream-string-width
+    (genera-clim::genera-medium t))
+  (text-size
+    (genera-clim::genera-medium t))
+  (text-style-ascent
+    (standard-text-style genera-clim::genera-medium))
+  (text-style-descent
+    (standard-text-style genera-clim::genera-medium))
+  (text-style-height
+    (standard-text-style genera-clim::genera-medium))
+  (text-style-width
+    (standard-text-style genera-clim::genera-medium))
+  (clos-internals::which-operations
+    (genera-clim::genera-medium))
+  (genera-clim::with-appropriate-drawing-state
+    (genera-clim::genera-medium t t t t)))
+
+
+;;; (generate-prefill-dispatch-caches 'genera-clim::genera-port)
+
+(prefill-dispatch-caches
+  (degraft-medium)
+  (disable-mirror
+    (genera-clim::genera-port t))
+  (distribute-event
+    (genera-clim::genera-port t))
+  (distribute-event-1
+    (genera-clim::genera-port pointer-button-release-event)
+    (genera-clim::genera-port pointer-button-press-event)
+    (genera-clim::genera-port key-press-event)
+    (genera-clim::genera-port key-release-event)
+    (genera-clim::genera-port pointer-motion-event))
+  (enable-mirror
+    (genera-clim::genera-port t))
+  (engraft-medium)
+  (genera-clim::genera-mirror-native-edges*
+    (genera-clim::genera-port t))
+  (genera-clim::initialize-genera-port
+    (genera-clim::genera-port))
+  (initialize-menu
+    (genera-clim::genera-port clim-stream-pane t))
+  (make-frame-manager
+    (genera-clim::genera-port))
+  (make-medium
+    (genera-clim::genera-port t))
+  (mirror-inside-edges*
+    (genera-clim::genera-port t))
+  (mirror-native-edges*
+    (genera-clim::genera-port t))
+  (mirror-region
+    (genera-clim::genera-port t))
+  (mirror-region*
+    (genera-clim::genera-port t))
+  (mirror-region-updated
+    (genera-clim::genera-port top-level-sheet))
+  (clos-internals:operation-handled-p
+    (genera-clim::genera-port t))
+  ((setf port)
+    (genera-clim::genera-port t))
+  (port-event-loop
+    (genera-clim::genera-port))
+  (port-glyph-for-character
+    (genera-clim::genera-port t t))
+  (port-graft-class
+    (genera-clim::genera-port))
+  (port-grafts
+    (genera-clim::genera-port))
+  ((setf port-grafts)
+    (t genera-clim::genera-port))
+  ((setf port-keyboard-input-focus)
+    (t genera-clim::genera-port))
+  (port-note-cursor-change
+    (genera-clim::genera-port t t (eql 'cursor-focus) t t)
+    (genera-clim::genera-port t t (eql 'cursor-active) t t)
+    (genera-clim::genera-port t t (eql 'cursor-state) t t))
+  (port-pointer
+    (genera-clim::genera-port))
+  ((setf port-pointer)
+    (t genera-clim::genera-port))
+  ((setf port-process)
+    (t genera-clim::genera-port))
+  (port-server-path
+    (genera-clim::genera-port))
+  (medium-text-bounding-box
+    (genera-clim::genera-medium t t t t t t t t t t t t))
+  (port-trace-thing
+    (genera-clim::genera-port))
+  (port-type
+    (genera-clim::genera-port))
+  (print-object
+    (genera-clim::genera-port t))
+  (clos-internals::print-self
+    (genera-clim::genera-port t t t))
+  (process-next-event
+    (genera-clim::genera-port))
+  (realize-graft
+    (genera-clim::genera-port t))
+  (realize-mirror
+    (genera-clim::genera-port top-level-sheet))
+  (restart-port
+    (genera-clim::genera-port))
+  (clos-internals::send-if-handles
+    (genera-clim::genera-port t))
+  (set-sheet-mirror-edges*
+    (genera-clim::genera-port t t t t t))
+  (shared-initialize
+    (genera-clim::genera-port t))
+  (standardize-text-style
+    (genera-clim::genera-port t))
+  (text-style-mapping
+    (genera-clim::genera-port standard-text-style))
+  ((setf text-style-mapping)
+    (t genera-clim::genera-port t))
+  (text-style-mapping*
+    (genera-clim::genera-port t))
+  (update-mirror-region
+    (genera-clim::genera-port top-level-sheet))
+  (update-mirror-region-1
+    (genera-clim::genera-port t t))
+  (update-mirror-transformation
+    (genera-clim::genera-port top-level-sheet)
+    (genera-clim::genera-port standard-graft))
+  (update-mirror-transformation-1
+    (genera-clim::genera-port t t))
+  (clos-internals::which-operations
+    (genera-clim::genera-port)))
+
-- 
GitLab