;;; -*- Mode:LISP; Package:(PAINT GLOBAL); Base:10; Readtable:ZL -*-

;;;; Extended Graphics Routines for Paint

;;; LMI -- EFH
 

(defmacro define-pattern (name &body rows)
  `(defconst ,name (make-pattern ,@rows)))

(defun make-pattern (&rest rows)
  (let ((array (make-array '(8 32) :type 'art-1b)))
    (loop for y from 0
	  for row in rows
          do (loop for x from 0 to 31
		   do (aset (load-byte row (mod x 8) 1) array y x)))
    array))

(define-pattern black
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111)

(define-pattern white
  #b00000000
  #b00000000
  #b00000000
  #b00000000
  #b00000000
  #b00000000
  #b00000000
  #b00000000)

(define-pattern light-gray
  #b00010001
  #b01000100
  #b00010001
  #b01000100
  #b00010001
  #b01000100
  #b00010001
  #b01000100)
  
(define-pattern gray
  #b01010101
  #b10101010
  #b01010101
  #b10101010
  #b01010101
  #b10101010
  #b01010101
  #b10101010)

(define-pattern dark-gray
  #b11101110
  #b10111011
  #b11101110
  #b10111011
  #b11101110
  #b10111011
  #b11101110
  #b10111011)

(define-pattern hline
 #b11111111
 #b00000000
 #b00000000
 #b00000000
 #b11111111
 #b00000000
 #b00000000
 #b00000000)


(define-pattern vline
  #b10001000
  #b10001000
  #b10001000
  #b10001000
  #b10001000
  #b10001000
  #b10001000
  #b10001000)

(define-pattern bar-sinister
  #b00010001
  #b00100010
  #b01000100
  #b10001000
  #b00010001
  #b00100010
  #b01000100
  #b10001000)

(define-pattern bar-dexter
  #b10001000
  #b01000100
  #b00100010
  #b00010001
  #b10001000
  #b01000100
  #b00100010
  #b00010001)

(define-pattern checks
  #b11110000
  #b11110000
  #b11110000
  #b11110000
  #b00001111
  #b00001111
  #b00001111
  #b00001111)

(define-pattern grids
  #b10001000
  #b10001000
  #b10001000
  #b11111111
  #b10001000
  #b10001000
  #b10001000
  #b11111111)

(define-pattern dots
  #b10001000
  #b00000000
  #b00000000
  #b00000000
  #b10001000
  #b00000000
  #b00000000
  #b00000000)

(define-pattern scales
  #b10000000
  #b10000000
  #b01000001
  #b00111110
  #b00001000
  #b00001000
  #b00010100
  #b11100011)



;(defmacro defbrush (name &body rows)
;  `(defvar ,name
;	   (make-array 8 :type 'art-8b
;		       :initial-contents
;		       ',rows)))


(define-pattern small-round-brush
  #b00000000
  #b00000000
  #b00011000
  #b00111100
  #b00111100
  #b00011000
  #b00000000
  #b00000000)

(define-pattern large-round-brush
  #b00111100
  #b01111110
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b01111110
  #b00111100)

(define-pattern small-square-brush
  #b00000000
  #b00000000
  #b00111100
  #b00111100
  #b00111100
  #b00111100
  #b00000000
  #b00000000)

(define-pattern large-square-brush
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111
  #b11111111)

(define-pattern horizontal-brush
  #b00000000
  #b00000000
  #b00000000
  #b11111111
  #b11111111
  #b00000000
  #b00000000
  #b00000000)

(define-pattern vertical-brush
  #b00011000
  #b00011000
  #b00011000
  #b00011000
  #b00011000
  #b00011000
  #b00011000
  #b00011000)

(define-pattern diagonal-brush
  #b10000000
  #b11000000
  #b01100000
  #b00110000
  #b00011000
  #b00001100
  #b00000110
  #b00000011)





(defstruct (rectangle :named
		      (:conc-name "RECT-")
		      (:constructor %make-rect))
  "A rectangle"
  (top 0)
  (left 0)
  (bottom 0)
  (right 0)
  (height 0)
  (width 0))

(defun make-rect (&key (top 0) (left 0) (bottom nil) (right nil) (height 0) (width 0))
  (let ((b (or bottom (+ top height)))
	(r (or right (+ left width))))
    (%make-rect :top top :left left :bottom b :right r :width (- r left) :height (- b top))))

(defmacro with-rect ((top l b r w h) rect &body body)
  (once-only (rect)
    `(let (,@(if top `((,top (rect-top ,rect))))
	   ,@(if l `((,l (rect-left ,rect))))
	   ,@(if b `((,b (rect-bottom ,rect))))
	   ,@(if r `((,r (rect-right ,rect))))
	   ,@(if w `((,w (rect-width ,rect))))
	   ,@(if h `((,h (rect-height ,rect)))))
       ,@body)))

(defun set-rect (rect top left bottom right)
  (setf (rect-top rect) top)
  (setf (rect-left rect) left)
  (setf (rect-bottom rect) bottom)
  (setf (rect-right rect) right)
  (setf (rect-width rect) (- right left))
  (setf (rect-height rect) (- bottom top)))


(defmacro within-rect-p (x y top left bottom right)
  (once-only (x y)
    `(and (> ,x ,left)
	  (> ,y ,top)
	  (< ,x ,right)
	  (< ,y ,bottom))))

(defun within-rect? (x y rect)
  (within-rect-p x y
		 (rect-top rect)
		 (rect-left rect)
		 (rect-bottom rect)
		 (rect-right rect)))

(defun rect-select (x y top left width h v)
  (+ (fix (// (- x left)
	      h))
     (* (fix (// width h))
	(fix (// (- y top)
		 v)))))


(defun clear-rect-shadowed (window rect &optional (shadow-thickness 3))
  (with-rect (top left nil nil width height) rect
    (send window :draw-rectangle width height left top tv:alu-andca)
    (send window :draw-rectangle width 1 (1- left) (1- top) tv:alu-ior)
    (send window :draw-rectangle 1 height (1- left) (1- top) tv:alu-ior)
    (send window :draw-rectangle (+ shadow-thickness width) shadow-thickness
	  (1- left)  (+ top height) tv:alu-ior)
    (send window :draw-rectangle shadow-thickness (+ shadow-thickness height)
	  (+ left width) (1- top) tv:alu-ior)))

(defun frame-rect (width height x y sheet alu thick)
  (tv:prepare-sheet (sheet)
    (tv:%draw-rectangle-clipped (- width thick) thick x y alu sheet)
    (tv:%draw-rectangle-clipped thick (- height thick) (- (+ width x) thick) y alu sheet)
    (tv:%draw-rectangle-clipped (- width thick) thick (+ x thick) (- (+ y height) thick) alu sheet)
    (tv:%draw-rectangle-clipped thick (- height thick) x (+ y thick) alu sheet)))


(defun good-array-width (width)
   (* (ceiling (//  width 32.0s0)) 32))


;;; This is not fast enough
;;; there might be some way to get rid of the multiplies

;;; maybe this should use draw-wide-curve???

(defmacro draw-point (x-form y-form)
  `(progn
     (setq x-val ,x-form
	   y-val ,y-form)
     (as-2-reverse (boole alu -1 (ar-2-reverse screen-array x-val y-val))
		   screen-array x-val y-val)))

(defun frame-ellipse (width height left top sheet alu thick)
  thick
  (unless (or (zerop width) (zerop height))
  (tv:prepare-sheet (sheet)
    (let* ((radius (// width 2))
	 (e (small-float (// (float width) (float height))))
	 (cx (fixr (+ left radius)))
	 (cy (fixr (+ top (// height 2))))
	 (screen-array (send sheet :screen-array))
	 (x 0)
	 (y (fixr (// radius e)))
	 (e^2 (^ e 2))
	 (4*e2 (* 4 e^2))
	 (m4e2 (- 4*e2))
	 (6*e2 (* 6 e^2))
	 (6+4e2 (+ 6 4*e2))
	 (4+6e2 (+ 4 6*e2))
	 (d (+ 2 e^2 (* -2 e radius)))
	 (f (fix (* radius (// e (sqrt (1+ e^2)))))) ;this is the point where the slope becomes < -1
	 x-val y-val)
    (do () ((= x f))
      (draw-point  (+ cx x) (+ cy y))
      (draw-point  (+ cx x) (- cy y))
      (draw-point  (- cx x) (- cy y))
      (draw-point  (- cx x) (+ cy y))
      (if (minusp d)
	  (setq d (+ d (* 4 x) 6))		;inc x
	(setq d (+ d (* 4 x) (* m4e2 y) 6+4e2)) ;inc x, dec y
	(decf y))
      (incf x))
    (setq x radius)
    (setq y 0)
    (setq d (+ 1 (* -2 radius) (* -2 e^2)))
    (do () ((< x f))
      (draw-point  (+ cx x) (+ cy y))
      (draw-point  (+ cx x) (- cy y))
      (draw-point  (- cx x) (- cy y))
      (draw-point  (- cx x) (+ cy y))
      (if (minusp d)
	  (setq d (+ d (* 4*e2 y) 6*e2))		;inc y
	(setq d (+ d (* -4 x) (* 4*e2 y) 4+6e2))	;inc y, dec x
	(decf x))
      (incf y))))))

(defun solid-ellipse (width height left top sheet pattern alu)
  (unless (or (zerop width) (zerop height))
    (tv:prepare-sheet (sheet)
      (let* ((radius (// width 2))
	     (e (small-float (// (float width) (float height))))
	     (cx (fixr (+ left radius)))
	     (cy (fixr (+ top (// height 2))))
	     (screen-array (send sheet :screen-array))
	     (x radius)
	     (y 0)
	     (e^2 (^ e 2))
	     (4*e2 (* 4 e^2))
	     (m4e2 (- 4*e2))
	     (6*e2 (* 6 e^2))
	     (6+4e2 (+ 6 4*e2))
	     (4+6e2 (+ 4 6*e2))
	     (d (+ 1 (* -2 radius) (* -2 e^2)))
	     (f (fix (* radius (// e (sqrt (1+ e^2))))))	;this is the point where the slope becomes < -1
	     (last-y y)
	     last-x
	     w h from-y from-x from-x-r to-y to-x to-x-r)
	(do () ((< x f))
	  (if (minusp d)
	      (setq d (+ d (* 4*e2 y) 6*e2))	;inc y
	    (setq d (+ d (* -4 x) (* 4*e2 y) 4+6e2))	;inc y, dec x
	    (setq w (* 2 x) h (- y last-y))	;draw the rectangles when x changes
	    (setq to-x (- cx x) from-x (mod to-x 8))
	    (setq to-y (- cy y) from-y (mod to-y 8))
	    (bitblt alu w h pattern from-x from-y screen-array to-x to-y)
	    (setq to-y (+ cy last-y) from-y (mod to-y 8))
	    (bitblt alu w h pattern from-x from-y screen-array to-x to-y)
	    (setq last-y y)
	    (decf x))
	  (incf y))
	(setq y (fixr (// radius e)))
	(setq x 0)
	(setq last-x x)
	(setq d (+ 2 e^2 (* -2 e radius)))
	(do () ((<= y last-y))
;      (setq w (- y last-y))
;      (format t "~a " w)
	  (if (minusp d)
	      (setq d (+ d (* 4 x) 6))		;inc x
	    (setq d (+ d (* 4 x) (* m4e2 y) 6+4e2))	;inc x, dec y
	    (setq w (- x last-x) h (- y last-y))	;draw the rectangles when y changes
	    (setq to-y (- cy y) from-y (mod to-y 8))
	    (setq to-x (- cx x) from-x (mod to-x 8))
	    (setq to-x-r (+ cx last-x) from-x-r (mod to-x-r 8))
	    (bitblt alu w h pattern from-x from-y screen-array to-x to-y)
	    (bitblt alu w h pattern from-x-r from-y screen-array to-x-r to-y)
	    (setq to-y (+ cy last-y) from-y (mod to-y 8))
	    (bitblt alu w h pattern from-x from-y screen-array to-x to-y)
	    (bitblt alu w h pattern from-x-r from-y screen-array to-x-r to-y)
	    (setq last-x x)
	    (decf y))
	  (incf x))))))


(defvar *x-array* (make-array 2))
(defvar *y-array* (make-array 2))
(defun draw-wide-line (x1 y1 x2 y2 width window  &optional (alu (send window :char-aluf)))
  (aset x1 *x-array* 0)
  (aset x2 *x-array* 1)
  (aset y1 *y-array* 0)
  (aset y2 *y-array* 1)
  (send window :draw-wide-curve *x-array* *y-array* width 2 alu))


(defvar *mixing-array* (make-array '(8 32) :type 'art-1b))

(defun daub (x y pattern brush sheet)
  (tv:prepare-sheet (sheet)
    (let ((screen-array (send sheet :screen-array)))
      (bitblt tv:alu-seta 8 8 pattern (mod x 8) (mod y 8) *mixing-array* 0 0)
      (bitblt tv:alu-and 8 8 brush 0 0 *mixing-array* 0 0)
      (bitblt tv:alu-andca 8 8 brush 0 0 screen-array x y)
      (bitblt tv:alu-ior 8 8 *mixing-array* 0 0 screen-array x y))))

(defun stroke (from-x from-y to-x to-y pattern brush sheet)
  (let* ((dx (- to-x from-x))
	 (dy (- to-y from-y))
	 (long (max (abs dx) (abs dy)))
	 (short (min (abs dx) (abs dy)))
	 (s (// long 2))
	 (screen-array (send sheet :screen-array)))
    (if (zerop long)
	(daub from-x from-y pattern brush sheet)
      (tv:prepare-sheet (sheet)
	(if (= long (abs dx))
	    (loop with ypos = from-y
		  with sdy = (signum dy)
		  repeat long
		  for xpos from from-x by (signum dx)
		  do (when (minusp (decf s short))
		       (incf ypos sdy)
		       (incf s long))
		  doing (bitblt tv:alu-seta 8 8 pattern (mod xpos 8) (mod ypos 8) *mixing-array* 0 0)
		  (bitblt tv:alu-and 8 8 brush 0 0 *mixing-array* 0 0)
		  (bitblt tv:alu-andca 8 8 brush 0 0 screen-array xpos ypos)
		  (bitblt tv:alu-ior 8 8 *mixing-array* 0 0 screen-array xpos ypos))
	  (loop with xpos = from-x
		with sdx = (signum dx)
		repeat long
		for ypos from from-y by (signum dy)
		do (when (minusp (decf s short))
		     (incf xpos sdx)
		     (incf s long))
		doing (bitblt tv:alu-seta 8 8 pattern (mod xpos 8) (mod ypos 8) *mixing-array* 0 0)
		(bitblt tv:alu-and 8 8 brush 0 0 *mixing-array* 0 0)
		(bitblt tv:alu-andca 8 8 brush 0 0 screen-array xpos ypos)
		(bitblt tv:alu-ior 8 8 *mixing-array* 0 0 screen-array xpos ypos)))))))