root/trunk/lisp/lmdemo/cafe.lisp @ 269

Revision 269, 5.8 KB (checked in by rjs, 3 years ago)

Initial versions from System 78.

Line 
1;;; -*- Mode:LISP; Package:hacks; Lowercase: T -*-
2
3;;; This program creates a color window and paints it with a familiar
4;;; optical-illusion pattern whose name I can't remember at the moment.
5;;; By frobbing the color map, you can see how various color versions
6;;; of the illusion look.
7;;; It is based on the function "checker" in MC: RWG1; PREHAX.
8
9;;; It only works if you have a color monitor.
10
11;;; The window to use, created when needed by color-checker.
12(defvar *cc-window* nil)
13
14;;; Parameters:
15(defconst *cc-n-columns* 22)                    ; Number of columns.
16(defconst *cc-n-rows* 22)                       ; Number of rows.
17(defconst *cc-spacer-fraction* .0625s0)         ; Fraction of height devoted to spacer.
18
19(defun draw-color-into-rectangle (window color x1 y1 x2 y2)
20  (color:color-bitblt (+ (min (max x1 0) (tv:sheet-inside-width window))
21                         (tv:sheet-left-margin-size window))
22                      (+ (min (max y1 0) (tv:sheet-inside-height window))
23                         (tv:sheet-top-margin-size window))                       
24                      (+ (min (max x2 0) (tv:sheet-inside-width window))
25                         (tv:sheet-left-margin-size window))
26                      (+ (min (max y2 0) (tv:sheet-inside-height window))
27                         (tv:sheet-top-margin-size window))
28                      color
29                      tv:alu-seta
30                      window))
31
32;;; Create the *cc-window* if it doesn't exist already, expose and clear it.
33(defun initialize-cc-window ()
34  (if (null *cc-window*)
35      (setq *cc-window* (tv:make-window 'tv:window
36                                        ':superior color:color-screen
37                                        ':blinker-p nil ':borders nil
38                                        ':label nil)))
39  (funcall *cc-window* ':expose)
40  (funcall *cc-window* ':clear-screen))
41
42;;; This function draws the regular cafe wall pattern onto *cc-window*.
43;;; The blocks are drawn in colors 1 and 2, and the spacer is drawn in color 3.
44(defun draw-color-checker ()
45  (initialize-cc-window)
46  (multiple-value-bind (window-width window-height)
47      (funcall *cc-window* ':inside-size)
48    ;; The image is made up of a bunch of rows and columns.  Between successive
49    ;; rows are spacers, which use up some of the available height.
50    (let* ((width (// window-width *cc-n-columns*))
51           (height (// window-height *cc-n-rows*))
52           (spacer-height (fixr (* height *cc-spacer-fraction*))))
53      (dotimes (row *cc-n-rows*)
54        ;; Do this for each row:
55        (let* ((y1 (* row height))
56               (y2 (- (+ y1 height) spacer-height)))
57          ;; y1 and y2 are the top and bottom of the bricks in this row.
58          (do ((x (if (evenp row) 0 (- (// width 2))) (+ x width))
59               (color 1 (- 3 color)))
60              (( x window-width))
61            ;; x is where to start; every other row is offset by half.
62            ;; color is the color to draw; it alternates between 1 and 2.
63            ;; Do this for each column.
64            (draw-color-into-rectangle *cc-window* color x y1 (+ x width) y2))
65          (draw-color-into-rectangle *cc-window* 3 0 y2 window-width (+ y2 spacer-height)))))))
66
67;;; Top level function to produce regular B&W effect.
68(defun cch ()
69  (color:write-color-map 1 0 0 0)
70  (color:write-color-map 2 377 377 377)
71  (color:write-color-map 3 200 200 200)
72  (draw-color-checker))
73
74(defun cchc (&optional (wait 1000) (speed 0.03s0))
75  (cch)
76  (do ((angle 0.0s0 (+ angle speed)))
77      (nil)
78    (let* ((x (max 0 (min 377 (+ 200 (fixr (* 200.0s0 (sin angle)))))))
79           (y (- 377 x)))
80      (color:write-color-map 1 x x x)
81      (color:write-color-map 2 y y y))
82    (dotimes (i wait))))
83
84;;; This has the problem that linear motion would probably look better than sine.
85;;; Try making each odd row out of two new colors, and even rows get black->gray-> black
86;;; while odd rows get black->gray->white.  Also try using lots of color map
87;;; entries in stripes to get real motion in animation, moving every other row
88;;; or moving alternate rows in alternate directions.
89
90;;; This function also draws the cafe wall pattern, but in a more complicated
91;;; way to allow hairier animation.  Color 0 is reserved for the background
92;;; and color 17 for the spacer.  Then, even rows are drawn using colors
93;;; 1 through 16, and odd rows are drawn using colors 16 through 1 (i.e. in
94;;; the other order.
95(defun draw-elaborate-color-checker ()
96  (initialize-cc-window)
97  (multiple-value-bind (window-width window-height)
98      (funcall *cc-window* ':inside-size)
99    ;; The image is made up of a bunch of rows and columns.  Between successive
100    ;; rows are spacers, which use up some of the available height.
101    (let* ((width (// window-width *cc-n-columns*))
102           (height (// window-height *cc-n-rows*))
103           (spacer-height (fixr (* height *cc-spacer-fraction*))))
104      (dotimes (row *cc-n-rows*)
105        ;; Do this for each row:
106        (let* ((y1 (* row height))
107               (y2 (- (+ y1 height) spacer-height)))
108          ;; y1 and y2 are the top and bottom of the bricks in this row.
109          (let* ((parity (evenp row))
110                 (strip-width (// width 7)))
111            (do ((x 0 (+ x strip-width))
112                 (color 0 (if parity
113                              (if ( color 16) 1 (1+ color))
114                              (if ( color 1) 16 (1- color)))))
115                (( x window-width))
116              (draw-color-into-rectangle *cc-window* color x y1 (+ x strip-width) y2)))
117          (draw-color-into-rectangle *cc-window* 17 0 y2
118                                     window-width (+ y2 spacer-height)))))))
119
120;;; This is the top level function.  It creates a cafe wall and slides alternate
121;;; rows in alternate directions.
122(defun cafe-slide (&optional (wait 100))
123  (draw-elaborate-color-checker)
124  (color:write-color-map 0 0 0 0)
125  (loop for color from 1 to 7
126        do (color:write-color-map color 0 0 0))
127  (loop for color from 10 to 16
128        do (color:write-color-map color 377 377 377))
129  (color:write-color-map 17 200 200 200)
130  (funcall standard-input ':tyi)
131  (loop do
132        (loop for b-to-w from 1 to 16
133              do (hack-two-slots b-to-w
134                                 (1+ (\ (+ b-to-w 6) 16))
135                                 wait))
136           ;(if (funcall standard-input ':tyi-no-hang)
137           ;    (return))
138           ))
139
140(defun hack-two-slots (b-to-w w-to-b &optional (wait 1000))
141  (loop for x from 0 to 377
142        for y from 377 downto 0
143        do (color:write-color-map b-to-w x x x)
144           (color:write-color-map w-to-b y y y)
145           (dotimes (i wait))))
Note: See TracBrowser for help on using the browser.