;;; -*- Mode:LISP; Package:TV; Base:10; Readtable:ZL -*-
;;; Copyright ) 1988 by GigaMos Systems, Inc.  All Rights Reserved

;;; Each buffer is made up of four word Buckets  Each four-word bucket
;;; consists of two points, of two words each (X in the even, Y in the odd
;;; numbered locations).
;;; 
;;; Each bucket holds the max bounds to be copied in a *bucket-height*
;;; vertical slice of the screen, of at most *bucket-width-bytes* bytes.
;;; Superstition says *bucket-width-bytes* should be a multiple of 4 for nuBus
;;; efficiency sake, but I saw no trace of such effects in my Quickdraw
;;; timings.

;;; The imaging model here is the same as on the Macintosh.  Points have no width
;;; or height, and integral points fall BETWEEN pixels.  This model is much easier
;;; to deal with, since you don't have to deal with the size of things explicitly
;;; at every level.  When inserting a physical line with real width, do it as a
;;; rectangle or parallelogram.

(import (intern "GENSYMBOL" "COMPILER") "TV")

(defvar *other-buffer*)                      ;The buffer being processed by the Mac
(defvar *current-buffer*)                    ;The buffer we're filling

(defvar *bucket-height* 20.)                 ;How much of the screen to cover in each bucket.
(defvar *bucket-width*)                      ;(Filled in by init-buffers)
(defvar *bucket-width-bytes* 128.)           ;Maximum # of bytes width of each bucket.
(defvar *bucket-per-line*)                   ;(filled in by init-buffers)
(defvar *bucket-entries* 4)                  ;Number of entries per bucket.
(defvar *bucket-line-increment*)             ;(filled in by init-buffers) Bucket words per line

(defvar *default-screen-height* 2048)        ;Number of pixels high.
(defvar *default-screen-width* 2048)         ;Number of pixels wide.
(defvar *default-screen-depth* 1)            ;Number of pixels deep.

(defun init-buffers (&optional (width *default-screen-width*) (height *default-screen-height*)
                               (depth *default-screen-depth*))
  (let* ((pixels-per-byte (ceiling 8 depth))
         (wcount (ceiling width (* *bucket-width-bytes* pixels-per-byte)))
         (hcount (ceiling height *bucket-height*))
         (total (* wcount hcount *bucket-entries*)))
    (setq *bucket-width* (* 4 pixels-per-byte (ceiling (ceiling width wcount)
                                                       (* 4 pixels-per-byte)))
          *bucket-per-line* wcount
          *bucket-line-increment* (* wcount *bucket-entries*)
          *other-buffer* (make-array total
                                   :element-type '(unsigned-byte 15)
                                   :initial-element 0)
          *current-buffer* (make-array total
                                       :element-type '(unsigned-byte 15)
                                       :initial-element 0))
    (swap-buffers-internal)
    (swap-buffers-internal)))

;;; The Mac is done with the other buffer, make it current and empty it.
(defun swap-buffers-internal ()
  (rotatef *current-buffer* *other-buffer*)
  (do ((buffer *current-buffer*)
       (max #o37777)
       (idx 0 (+ idx *bucket-entries*)))
      ((>= idx (length *current-buffer*)))
    (setf (aref buffer idx) max
          (aref buffer (1+ idx)) max
          (aref buffer (+ idx 2)) 0
          (aref buffer (+ idx 3)) 0)))

(defvar *gensymbol-counter* 0)

(defun show-insert-entry (idx xmin ymin xmax ymax)
  (format t "~&~D: ~D,~D -- ~D,~D~%"
          idx xmin ymin xmax ymax))

(defmacro insert-entry (buffer idx xmin ymin xmax ymax)
  (let ((idx1 (gensymbol "YMIN"))
        (idx2 (gensymbol "XMAX"))
        (idx3 (gensymbol "YMAX")))
    `(let ((,idx1 (1+ ,idx))
           (,idx2 (+ ,idx 2))
           (,idx3 (+ ,idx 3)))
       (show-insert-entry ,idx ,xmin ,ymin ,xmax ,ymax)
       (setf (aref ,buffer ,idx) (min (aref ,buffer ,idx) ,xmin)
             (aref ,buffer ,idx1) (min (aref ,buffer ,idx1) ,ymin)
             (aref ,buffer ,idx2) (max (aref ,buffer ,idx2) ,xmax)
             (aref ,buffer ,idx3) (max (aref ,buffer ,idx3) ,ymax)))))

(defun insert-line (x1 y1 x2 y2)
  (if (< y2 y1)
    ;; Always do things top-to-bottom
    (insert-line x2 y2 x1 y1)
    (if (= y1 y2)
      (insert-horizontal-line x1 y1 x2 y2)
      (if (= x1 x2)
        (insert-vertical-line x1 y1 x2 y2)
        (insert-line-internal x1 y1 x2 y2)))))

;;; The horizontal and vertical cases have to deal with the case where the line
;;; falls on a bucket boundary.  In all other cases, we don't need to know which
;;; side of this line the region falls on, because the other side will be done in
;;; the same bucket later.  But for these boundary cases, we need to indicate which
;;; bucket will contain the region.  Diagonal lines don't have this problem, because
;;; the line itself indicates which side.

;;; The trivial case.  Y1=Y2
(defun insert-horizontal-line (x1 y1 x2 y2 top-p)
  (if (< x2 x1)
    ;; Always do things left-to-right
    (insert-horizontal-line x2 y2 x1 y1 top-p)
    (do* ((buffer *current-buffer*)
          (xmin x1 xmax)
          (hbucket (floor xmin *bucket-width*)
                   (1+ hbucket))
          (xmax (min x2 (* (1+ hbucket) *bucket-width*))
                (min x2 (+ xmax *bucket-width*)))
          (vbucket (floor y1 *bucket-height*))
	  (vbucket2 (when (= y1 (* vbucket *bucket-height*))
		      (unless (zerop vbucket)
			(1- vbucket))))
          (hidx (* vbucket *bucket-per-line*))
	  (hidx2 (when vbucket2
		   (* vbucket *bucket-per-line*)))
          (idx1 (* (+ hidx hbucket) *bucket-entries*) (+ idx1 *bucket-entries*))
	  (idx2 (when hidx2
		  (* (+ hidx2 hbucket) *bucket-entries*))
		(when idx2 (+ idx2 *bucket-entries*)))
	  (idx (if (and idx2 top-p)
		   idx2
		 idx1)
	       (if (and idx2 top-p)
		   idx2
		 idx1)))
         ((>= xmin x2))
      (insert-entry buffer idx xmin y1 xmax y2))))

;;; The trivial case.  X1=X2
(defun insert-vertical-line (x1 y1 x2 y2 left-p)
  (if (< y2 y1)
    ;; Always do things top-to-bottom
    (insert-vertical-line x2 y2 x1 y1 left-p)
    (do* ((buffer *current-buffer*)
          (ymin y1 ymax)
          (hbucket (floor x1 *bucket-width*))
	  (hbucket2 (when (= x1 (* hbucket *bucket-width*))
		      (unless (zerop hbucket)
			(1- hbucket))))
          (vbucket (floor y1 *bucket-height*))
          (ymax (min y2 (* (1+ vbucket) *bucket-height*))
                (min y2 (+ ymax *bucket-height*)))
          (hidx (* vbucket *bucket-per-line*))
          (idx1 (* (+ hidx hbucket) *bucket-entries*)
		(+ idx1 *bucket-line-increment*))
	  (idx2 (when hbucket2
		  (* (+ hidx hbucket2) *bucket-entries*))
		(when idx2
		  (+ idx2 *bucket-line-increment*)))
	  (idx (if (and idx2 left-p)
		   idx2
		 idx1)
	       (if (and idx2 left-p)
		   idx2
		 idx1)))
         ((>= ymin y2))
      (insert-entry buffer idx x1 ymin x2 ymax))))

;;; Tough case.  Gotta deal in slope.  To avoid floating point, deal in
;;; fixed point, with 12 fractional bits after the 'binary'-point.
;;; To avoid checking which way to run the end-tests and increments
;;; each time around the inner X-loop, we split it into two cases,
;;; -UP and -DOWN, even though this means duplicating some code.

(defun insert-line-internal (x1 y1 x2 y2)
  (if (< x1 x2)
    (insert-line-down x1 y1 x2 y2)
    (insert-line-up x1 y1 x2 y2)))

;;; X grows as Y (slope positive) (Remember, the screen is an inverted coordinate system!)

(defun insert-line-down (x1 y1 x2 y2)
  (do* ((buffer *current-buffer*)
        (slope (round (ash (- y2 y1) 12) (- x2 x1)))
        (islope (round (ash (- x2 x1) 12) (- y2 y1)))
        (yend (ash y2 12))
        (xend (ash x2 12))
        (ymin (ash y1 12) ymax)
        (xmin (ash x1 12) xmax)
        (vbucket (floor (ash ymin -12) *bucket-height*) (1+ vbucket))
        (hbucket (floor (ash xmin -12) *bucket-width*))
        (vheight (ash *bucket-height* 12))
                (xinc (* *bucket-height* islope))
        (ymax (min yend (ash (* (1+ vbucket) *bucket-height*) 12))
              (min yend (+ ymax vheight)))
        (xmax (min xend (+ xmin (ash (* (- ymax ymin) islope) -12)))
              (min xend (+ xmin xinc))))
       ((>= ymin yend))
    (do* ((xmin1 xmin xmax1)
          (hwidth (ash *bucket-width* 12))
          (xmax1 (min xmax (ash (* (1+  hbucket) *bucket-width*) 12))
                (min xmax (+ xmax1 hwidth)))
          (ymin1 ymin ymax1)
          (yinc (* *bucket-width* slope))
          (ymax1 (max ymax (+ ymin1 (ash (* (- xmax1 xmin1) slope) -12)))
                 (max ymax (+ ymax1 yinc)))
          (xmin2 (ash xmin1 -12))
          (ymin2 (ash ymin1 -12))
          (xmax2 (ash xmax1 -12))
          (ymax2 (ash ymax1 -12))
          (hidx (* vbucket *bucket-per-line*))
          (idx (* (+ hidx hbucket) *bucket-entries*)
               (1+ idx)))
         ((>= xmin1 xmax))
      (insert-entry buffer idx xmin2 ymin2 xmax2 ymax2))))

;;; X grows as -Y (slope negative) (Remember, the screen is an inverted coordinate system!)

(defun insert-line-up (x1 y1 x2 y2)
  (do* ((buffer *current-buffer*)
        (slope (round (ash (- y2 y1) 12) (- x2 x1)))
        (islope (round (ash (- x2 x1) 12) (- y2 y1)))
        (yend (ash y2 12))
        (xend (ash x2 12))
        (ymin (ash y1 12) ymax)
        (xmax (ash x1 12) xmin)
        (vbucket (floor (ash ymin -12) *bucket-height*) (1+ vbucket))
        (vheight (ash *bucket-height* 12))
        (xinc (* *bucket-height* islope))
        (ymax (min yend (ash (* (1+ vbucket) *bucket-height*) 12))
              (min yend (+ ymax vheight)))
        (xmin (max xend (+ xmax (ash (* (- ymax ymin) islope) -12)))
              (max xend (+ xmin xinc)))
        (hbucket (floor (ash xmin -12) *bucket-width*)))
       ((>= ymin yend))
    (do* ((xmin1 xmin xmax1)
          (hwidth (ash *bucket-width* 12))
          (xmax1 (min xmax (ash (* (1+  hbucket) *bucket-width*) 12))
                 (min xmax (+ xmax1 hwidth)))
          (ymax1 ymax ymin1)
          (yinc (* *bucket-width* slope))
          (ymin1 (min ymin (+ ymax1 (ash (* (- xmax1 xmin1) slope) -12)))
                 (min ymin (+ ymin1 yinc)))
          (xmin2 (ash xmin1 -12))
          (ymin2 (ash ymin1 -12))
          (xmax2 (ash xmax1 -12))
          (ymax2 (ash ymax1 -12))
          (hidx (* vbucket *bucket-per-line*))
          (idx (* (+ hidx hbucket) *bucket-entries*)
               (1+ idx)))
         ((>= xmin1 xmax))
      (insert-entry buffer idx xmin2 ymin2 xmax2 ymax2))))


;;; Insert an unrotated rectangle.
(defun insert-aligned-rectangle (x1 y1 x2 y2)
  ;; Handle the left and right boundary cases
  (insert-line x1 y1 x1 y2)
  (insert-line x2 y1 x2 y2)
  ;; Handle the cases between the boundaries
  (loop for xlow from (* (ceiling x1 32) 32) by 32 below x2
	for xhigh = (+ xlow 32)
	do (insert-line xlow y1 xlow y2)
	   (insert-line xhigh y1 xhigh y2)))

(defun insert-triangle (x1 y1 x2 y2 x3 y3)
  (insert-line x1 y1 x2 y2)
  (insert-line x2 y2 x3 y3)
  (insert-line x3 y3 x1 y1)
  (loop with min-x = (min x1 x2 y3)
	with max-x = (max x1 x2 x3)
	for xa from (* 32 (floor min-x 32)) by 32 below max-x
	for xb = (+ xa 32)
	do
	(loop with min-y = (min y1 y2 y3)
	      with max-y = (max y1 y2 y3)
	      for ya from (* 32 floor min-y 32) by 32 below max-y
	      for yb = (+ ya 32)
	      do
	      (when (inside-triangle-p xa ya x1 y1 x2 y2 x2 y2)
		(insert-line