home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / x / volume3 / clover / part01 / clover.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1989-03-10  |  12.9 KB  |  390 lines
  1.  ;;; -*- Mode: LISP;  Package: hacks; base: 8; lowercase: t -*-
  2.  
  3. (defvar *color-screen-array*)
  4.  
  5. (defsubst //- (n d) (floor n d))
  6.  
  7. (defun \- (n d)
  8.   (multiple-value-bind (nil rem) (floor n d) rem))
  9.  
  10. (defsubst //+ (n d) (ceiling n d))
  11.  
  12. (defmacro plot (x1 y1)
  13.   `(as-2-reverse (1+ (ar-2-reverse *color-screen-array* ,x1 ,y1))
  14.          *color-screen-array*
  15.          ,x1
  16.          ,y1))
  17.  
  18. (defun draw-sym-line (x0 y0 xn yn &optional ignore ignore
  19.              &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
  20.        (draw-sym-subline x0 y0 xn yn 0 max))
  21.  
  22. (defun draw-sym-fractional-line (x0 y0 xn yn begfrac endfrac
  23.                     &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
  24.        (draw-sym-subline x0 y0 xn yn
  25.              (- (fix (* -1 begfrac max)))
  26.              (fix (* endfrac max))))
  27.  
  28. (defun draw-sym-subline (x0 y0 xn yn i j &optional (dx (abs (- xn x0))) (dy (abs (- yn y0))))
  29.        (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot0 x0 y0 dx dy i j))
  30.                            ((line-loop #'plot1 y0 x0 dy dx i j))))
  31.                   ((cond ((> dx dy) (line-loop #'plot7 x0 (- y0) dx dy i j))
  32.                      ((line-loop #'plot6 (- y0) x0 dy dx i j))))))
  33.          ((cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot3 (- x0) y0 dx dy i j))
  34.                      ((line-loop #'plot2 y0 (- x0) dy dx i j))))
  35.             ((cond ((> dx dy) (line-loop #'plot4 (- x0) (- y0) dx dy i j))
  36.                ((line-loop #'plot5 (- y0) (- x0) dy dx i j))))))))
  37.  
  38. (defun line-loop (fun x0 y0 dx dy i j
  39.               &aux (num (+ dx (* 2 i dy))))
  40.        (do ((j2 (min j (ash dx -1)))
  41.         (y (+ y0 (truncate num (ash dx 1))))
  42.         (i i (1+ i))
  43.         (x (+ x0 i) (1+ x))
  44.         (f (ash (- (\ num (ash dx 1)) dx) -1) (+ f dy)))
  45.        ((> i j2) (do ((i i (1+ i))
  46.               (x x (1+ x))
  47.               (f f (+ f dy)))
  48.              ((> i j))
  49.              (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
  50.              (funcall fun x y)))
  51.        (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
  52.        (funcall fun x y)))
  53.  
  54. (defun draw-clip-sym-line (x0 y0 xn yn xe ye xf yf
  55.                 &optional (dx (abs (- xn x0))) (dy (abs (- yn y0))))
  56.        (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy)
  57.                         (line-clip #'plot0 x0 y0 dx dy xe ye xf yf))
  58.                            ((line-clip #'plot1 y0 x0 dy dx ye xe yf xf))))
  59.                   ((cond ((> dx dy)
  60.                       (line-clip #'plot7 x0 (- y0) dx dy xe (- yf) xf (- ye)))
  61.                      ((line-clip #'plot6 (- y0) x0 dy dx (- yf) xe (- ye) xf))))))
  62.          ((cond ((> yn y0)
  63.              (cond ((> dx dy)
  64.                 (line-clip #'plot3 (- x0) y0 dx dy (- xf) ye (- xe) yf))
  65.                ((line-clip #'plot2 y0 (- x0) dy dx ye (- xf) yf (- xe)))))
  66.             ((cond ((> dx dy)
  67.                 (line-clip #'plot4 (- x0) (- y0) dx dy (- xf) (- yf) (- xe) (- ye)))
  68.                ((line-clip #'plot5 (- y0) (- x0) dy dx (- yf) (- xf) (- ye) (- xe)))))))))
  69. ;clip symmetric segment (x0, y0) thru (xn, yn) to the rectangle (xe, ye) < (xf,yf)
  70.  
  71. (defun line-clip (fun x0 y0 dx dy xe ye xf yf
  72.               &aux (x (max x0 xe (if (= dy 0) xe (+ x0 (//+ (* dx
  73.                                        (1- (ash (- ye y0) 1)))
  74.                                     (ash dy 1))))))
  75.                    (num (+ dx (* 2 dy (- x x0))))
  76.                (lx (min xf (if (= dy 0) xf (+ x0 (//+ (* dx (1- (ash (- yf y0) 1)))
  77.                                  (ash dy 1)))))))
  78.        (do ((xx (min (+ x0 (ash dx -1)) lx))
  79.         (y (+ y0 (//- num (ash dx 1))))
  80.         (x x (1+ x))
  81.         (f (ash (- (\- num (ash dx 1)) dx) -1) (+ f dy)))
  82.        ((> x xx) (do ((xx lx)
  83.               (x x (1+ x))
  84.               (f f (+ f dy)))
  85.              ((> x xx))
  86.              (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
  87.              (funcall fun x y)))
  88.        (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
  89.        (funcall fun x y)))
  90.  
  91. ;line-clip incorrectly assumes that subsegment starts prior to midpoint of supersegment.
  92. ;the "divide for nearest integer" (ie divide for remainder of minimum magnitude),
  93. ;which is simulated the //- and \- of num and (ash dx 1), always rounds up on the
  94. ;half integer case, but should round down (for symmetry) if startup is in 2nd half.
  95. ;it would be nice to have these other flavors of divide.
  96.  
  97. (defun plot0 (x y) (plot x y))
  98. (defun plot1 (x y) (plot y x))
  99. (defun plot2 (x y) (plot (- y) x))
  100. (defun plot3 (x y) (plot (- x) y))
  101. (defun plot4 (x y) (plot (- x) (- y)))
  102. (defun plot5 (x y) (plot (- y) (- x)))
  103. (defun plot6 (x y) (plot y (- x)))
  104. (defun plot7 (x y) (plot x (- y)))
  105.  
  106. (declare (special min-x min-y max-x max-y mid-x mid-y beg end))
  107.  
  108. (COMMENT
  109. (defun semi-circ (r &optional (y 0) (x r) (f 0))
  110. ;  (color:clear)
  111.   (let ((min-x (screen-x1 tv-color-screen))
  112.     (min-y (screen-y1 tv-color-screen))
  113.     (max-x (1- (screen-x2 tv-color-screen)))
  114.     (max-y (1- (screen-y2 tv-color-screen)))
  115.     (mid-x (truncate (screen-width tv-color-screen) 2))
  116.     (mid-y (truncate (screen-height tv-color-screen) 2)))
  117.     (semi-circ-1 r y x f)))  )
  118.  
  119. (defun semi-circ-1 (r y x f)
  120.       (rect-points x y)
  121.       (and (< y (1- x)) (semi-circ-1 r
  122.                      (1+ y)
  123.                      (cond (( (setq f (+ f y y 1)) x)
  124.                         (setq f (- f x x -1))
  125.                         (1- x))
  126.                        (t x))
  127.                      f))
  128.       (and ( x y) ( y 0) (rect-points y x)))
  129.  
  130. (defun semi-wedge (r)
  131. ;  (color:clear)
  132.   (MULTIPLE-VALUE-BIND (MIN-X MIN-Y MAX-X MAX-Y)
  133.       (FUNCALL COLOR:COLOR-SCREEN ':EDGES)
  134.     (SETQ MAX-X (1- MAX-X) MAX-Y (1- MAX-Y))
  135.     (let ((mid-x (truncate (- MAX-X MIN-X) 2))
  136.       (mid-y (truncate (- MAX-Y MIN-Y) 2)))
  137.       (do ((y 0 (1+ y))
  138.        (x r)
  139.        (f 0 (+ f y y 1)))
  140.       ((> y x))
  141.     (and ( f x) (setq x (1- x) f (- f x x -1)))
  142.     (draw-clip-sym-line mid-x mid-y (+ x mid-x) (+ y mid-y) min-x min-y max-x max-y))
  143.       (do ((a (TV:SHEET-SCREEN-ARRAY COLOR:COLOR-SCREEN))
  144.      (x mid-x (1+ x)))
  145.     ((> x max-x))
  146.       (as-2-reverse (1- (ash (ar-2-reverse a x mid-y) 1)) a x mid-y)
  147.       (and ( (+ x (- mid-x) mid-y) max-y)
  148.        (as-2-reverse
  149.          (1- (ash (ar-2-reverse a x (+ x (- mid-x) mid-y)) 1))
  150.          a x (+ x (- mid-x) mid-y)))
  151.       (do ((yy (min max-y (+ x mid-y (- mid-x))))
  152.        (y mid-y (1+ y)))
  153.       ((> y yy))
  154.     (do ((v (ar-2-reverse a x y))
  155.          (x x (+ mid-x mid-y (- y)))
  156.          (y y (+ mid-y x (- mid-x)))
  157.          (i 0 (1+ i)))
  158.         (( i 4))
  159.       (and ( y max-y) (> y min-y)
  160.            (as-2-reverse (as-2-reverse v a (+ mid-x mid-x (- x)) y)
  161.                  a x y))))))))
  162.  
  163. (DEFUN NO-COLOR-DEMO ()
  164.   "Report that we can't do this demo."
  165.   ;;this is better than wedging the machine, or generating an ugly error, or doing nothing
  166.   (TV:NOTIFY NIL "Sorry, apparently you don't have a color screen."))
  167.  
  168. (defun smoking-clover (&optional (size 5432) (speed 4321))
  169.   "Displays a really neat pattern on the color screen.  Slowly at first, then speed up."
  170.   (COND ((COLOR:COLOR-EXISTS-P)
  171.      (WITH-REAL-TIME
  172.        (setq *color-screen-array* (tv:sheet-screen-array color:color-screen))
  173.        (COLOR:write-color-map 0 0 0 0)
  174.        (color:clear)
  175.        (COLOR:random-color-map)
  176.        (semi-wedge size)
  177.        (color-guard speed)))
  178.     (T
  179.      (NO-COLOR-DEMO))))
  180.  
  181. (defun semi-circ-1 (r y x f)
  182.       (rect-points x y)
  183.       (and (< y (1- x)) (semi-circ-1 r
  184.                      (1+ y)
  185.                      (cond (( (setq f (+ f y y 1)) x)
  186.                         (setq f (- f x x -1))
  187.                         (1- x))
  188.                        (t x))
  189.                      f))
  190.       (and ( x y) ( y 0) (rect-points y x)))
  191.  
  192. (defun mask-points (x y)
  193.       (draw-sym-fractional-line
  194.        (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) beg end)
  195.       (draw-sym-fractional-line
  196.        (+ mid-x y) (- mid-y x) (- mid-x y) (+ mid-y x) beg end))
  197.  
  198. (defun rect-points (x y)
  199.       (draw-clip-sym-line
  200.        (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) min-x min-y max-x max-y)
  201.       (draw-clip-sym-line
  202.        (+ mid-x y) (- mid-y x) (- mid-x y) (+ mid-y x) min-x min-y max-x max-y))
  203.  
  204. (defun mash-points (x y &aux (m1 (cond ((> y x) (1- mid-y))
  205.                        ((min mid-x
  206.                          (- (truncate (- (* mid-x mid-x (- y x))
  207.                             (* mid-y (- (* y mid-x) (* x mid-y))))
  208.                          (* x (- mid-y mid-x))) 5)))))
  209.                      (z (max x y)))
  210.     (draw-sym-subline
  211.        (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) (- z m1 -1) (+ z m1))
  212.         (or (= y 0) (draw-sym-subline
  213.        (- mid-x x) (+ mid-y y) (+ mid-x x) (- mid-y y) (- z m1 -1) (+ z m1))))
  214.  
  215. (defun color-ramp (red green blue)
  216.   (WITH-REAL-TIME
  217.       (do ((r 0 (+ r red))
  218.        (g 0 (+ g green))
  219.        (b 0 (+ b blue))
  220.        (i 0 (1+ i)))
  221.       ((= i 20))
  222.     (COLOR:write-color-map i r g b))))
  223.  
  224. (defun color-march (&optional (y 0))
  225.   (COND ((COLOR:COLOR-EXISTS-P)
  226.      (WITH-REAL-TIME
  227.        (do ((dr 0 (- (random 42) 20))
  228.         (dg -21 (- (random 42) 20))
  229.         (db 21 (- (random 42) 20)))
  230.            ((funcall terminal-io ':tyi-no-hang))
  231.          (multiple-value-bind (r g b) (COLOR:read-color-map y)
  232.            (do ((r r (+ r dr))
  233.             (g g (+ g dg))
  234.             (b b (+ b db)))
  235.            ((bit-test (logior r g b) 400))
  236.          (do ((i 17 (1- i))
  237.               (r r) (g g) (b b))
  238.              ((< i y))
  239.            (cond ((= (logand i 1) 1)
  240.               (do ((tv-adr (TV:screen-control-address color:color-screen)))
  241.                   ((bit-test (%xbus-read tv-adr) 40)))))
  242.            (COLOR:write-color-map-immediate i r g
  243.                             (prog1 b
  244.                                (multiple-value (r g b)
  245.                                  (COLOR:read-color-map i))))))))))
  246.     (T
  247.      (NO-COLOR-DEMO))))
  248.     
  249. (defun color-guard (&optional (snooze 0) (y 0)
  250.             &aux (map-values (make-array '(20 3)
  251.                          ':type 'art-8b)))
  252.       (do ((i 0 (1+ i))
  253.        (r) (g) (b))
  254.       (( i 20))
  255.     (multiple-value (r g b) (COLOR:read-color-map i))
  256.     (aset r map-values i 0)
  257.     (aset g map-values i 1)
  258.     (aset b map-values i 2))
  259.       (do ((dr 0 (- (random 42) 20))
  260.        (dg -21 (- (random 42) 20))
  261.        (db 21 (- (random 42) 20)))
  262.       ((funcall terminal-io ':tyi-no-hang) (return-array map-values))
  263.     (do ((r (aref map-values y 0) (+ r dr))
  264.          (g (aref map-values y 1) (+ g dg))
  265.          (b (aref map-values y 2) (+ b db)))
  266.         ((bit-test (logior r g b) 400))
  267.       (do ((i snooze (1- i))) ((< i 0)))
  268.       (do ((i 17 (1- i))
  269.            (or) (og) (ob)
  270.            (r r or)
  271.            (g g og)
  272.            (b b ob))
  273.           ((< i y))
  274.         (setq or (aref map-values i 0) og (aref map-values i 1) ob (aref map-values i 2))
  275.         (aset r map-values i 0)
  276.         (aset g map-values i 1)
  277.         (aset b map-values i 2))
  278.       (COLOR:blt-color-map map-values))))
  279.  
  280. (defun color-zoom (&optional (z 0) &aux (map-values (make-array '(20 3)
  281.                                 ':type 'art-8b)))
  282.       (do ((i 0 (1+ i))
  283.        (r) (g) (b))
  284.       (( i 20))
  285.     (multiple-value (r g b) (COLOR:read-color-map i))
  286.     (aset r map-values i 0)
  287.     (aset g map-values i 1)
  288.     (aset b map-values i 2))
  289.       (do ((j 1)
  290.        (dr 0 (- (random 80) 36))
  291.        (dg -21 (- (random 80) 36))
  292.        (db 21 (- (random 80) 36)))
  293.       ((funcall terminal-io ':tyi-no-hang) (return-array map-values))
  294.     (do ((r (aref map-values j 0) (+ r dr))
  295.          (g (aref map-values j 1) (+ g dg))
  296.          (b (aref map-values j 2) (+ b db)))
  297.         ((bit-test (logior r g b) 400))
  298.       (setq j (logand (1- j) 17))
  299.       (do ((i j (logand (1- i) 17))
  300.            (r r) (g g) (b b)
  301.            (rr)  (gg)  (bb)
  302.            (k 0 (1+ k)))
  303.           ((= k 20))
  304.         (do ((i 0 (1+ i)))((> i z)))    ;snooze
  305.         (setq rr (aref map-values i 0)
  306.           gg (aref map-values i 1)
  307.           bb (aref map-values i 2))
  308.         (aset r map-values i 0)
  309.         (aset g map-values i 1)
  310.         (aset b map-values i 2)
  311.         (setq r (ash (+ r (* 37 rr) 25) -5)
  312.           g (ash (+ g (* 37 gg) 25) -5)
  313.           b (ash (+ b (* 37 bb) 25) -5)))
  314.       (COLOR:blt-color-map map-values))))
  315.  
  316. (defun color-mash ()
  317.   (COND ((COLOR:COLOR-EXISTS-P)
  318.      (WITH-REAL-TIME
  319.        (do ((i 1)
  320.         (dr 0 (- (random 8) 4))
  321.         (dg -21 (- (random 8) 4))
  322.         (db 21 (- (random 8) 4)))
  323.            ((funcall terminal-io ':tyi-no-hang))
  324.          (multiple-value-bind (r g b) (COLOR:read-color-map i)
  325.            (do ((r r (+ r dr))
  326.             (g g (+ g dg))
  327.             (b b (+ b db)))
  328.            ((bit-test (logior r g b) 400))
  329.          ;        (and (bit-test i 1)
  330.          ;         (do ((tv-adr (screen-control-address tv-color-screen)))
  331.          ;             ((bit-test (%xbus-read tv-adr) 40))))
  332.          (COLOR:write-color-map (setq i (logand (1- i) 17))
  333.                     r
  334.                     g
  335.                     b
  336.                    t))))))
  337.     (T
  338.      (NO-COLOR-DEMO))))
  339.  
  340. (COMMENT
  341. (defun frac-tour (a b &optional (xx (screen-x2 tv-color-screen))
  342.                         (yy (screen-y2 tv-color-screen)))
  343.       (do ((pixel-array (screen-buffer-pixel-array tv-color-screen))
  344.        (x (screen-x1 tv-color-screen) (1+ x)))
  345.       (( x xx))
  346.     (do ((y (screen-y1 tv-color-screen) (1+ y)))
  347.         (( y yy))
  348.       (as-2-reverse (fracpart (+ (* a x) (* b y))) pixel-array x y)))) )
  349.  
  350. ;(defun fracpart (a) (fix (ash (- a (fix a)) 4)))
  351.  
  352. (defun fracpart (a) (- 17 (haulong (fix (ash (- a (fix (+ a .5))) 20)))))
  353.  
  354. (defun random-ramp ()
  355.   (COND ((COLOR:COLOR-EXISTS-P)
  356.      (WITH-REAL-TIME
  357.        (do ((i 0 (1+ i)))
  358.            ((= i 20))
  359.          (COLOR:write-color-map i (random (+ 17 (ash i 4)))
  360.                     (random (+ 17 (ash i 4)))
  361.                     (random (+ 17 (ash i 4)))))))
  362.     (T
  363.      (NO-COLOR-DEMO))))
  364.  
  365. (defun brighten ()
  366.   "Possibly make the color screen more visible."
  367.   (COND ((COLOR:COLOR-EXISTS-P)
  368.      (WITH-REAL-TIME
  369.        (do ((i 17 (- i 3))
  370.         (r 377 (- r 60))
  371.         (g 377 (- g 60))
  372.         (b 377 (- b 60)))
  373.            (( i 2))
  374.          (color:write-color-map i r 0 0)
  375.          (color:write-color-map (1- i) 0 g 0)
  376.          (color:write-color-map (- i 2) 0 0 b))
  377.        (color:write-color-map 0 0 0 0)))
  378.     (T
  379.      (NO-COLOR-DEMO))))
  380.  
  381. (defdemo "Color TV Hacks" "Various demos that run on the color screen, if you have one."
  382.   "Color"
  383.   ("Smoking Clover" "Gosper's spectacular display hack." (smoking-clover))
  384.   ("Cafe Slide" "Cafe wall illusion.  Type space to start it sliding." (cafe-slide))
  385.   ("Color Mash" "Mash up the color map." (color-mash))
  386.   ("Color March" "March colors through the color map." (color-march))
  387. ; ("Color Ramp" "This can't work." (color-ramp))
  388.   ("Random Ramp" "Randomize color map." (random-ramp))
  389.   ("Brighten" "" (brighten)))
  390.