;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Change Log:
;;;     date     who    what
;;;     ----     ---    ----
;;;    6-Oct-92  koz      changed #'update-slot-invalidated to a g-value
;;;                       of opal:GRAPHICAL-OBJECT :invalidate-demon
;;;   10-Mar-92  Pervin   Rewrote find-halftone.
;;;    3-Jan-92  Mickish  Changed to call with-demons-disabled.
;;;    4-Mar-91  D'Souza  Removed nickname "MO" of package Opal.
;;;   21-Feb-91  Pervin   Changed bitmap images in the halftone-table so that
;;;                       each halftone strictly contains the one before it.
;;;    8-May-90  Sannella The R4 CLX version of xlib:bitmap-image needs
;;;                       arguments like #*1011 instead of '#(1 1 0 1)
;;;   19-Mar-90  Pervin   Changed tile to stipple
;;;   13-Feb-90  Pervin   Implemented color.
;;;   07-Jul-89  Kosbie   Placed these within "WITH-DEMONS-DISABLED"
;;;   15-Jun-89  Kosbie   Added s-values to *-FILL-BITMAPs :image slots after the
;;;			  function "halftone-image" was defined.

(in-package "OPAL" :use '("LISP" "KR"))

(defun halftone-print (s stream ignore)
  (declare (ignore ignore))
  (format stream "#<Halftone ~D>" (halftone-percent s)))

;;; a bit inelegant, perhaps, but very clear
(defun build-halftone-table ()
  (let ((halftone-table (make-array *halftone-table-size*)))
    (setf (aref halftone-table 0)
	  (make-halftone :percent 0
			 :filling-style OPAL:WHITE-FILL
			 :x-image (xlib:bitmap-image #*0000
						     #*0000
						     #*0000
						     #*0000)))
    (setf (aref halftone-table 1)
	  (make-halftone :percent 6   
			 :x-image (xlib:bitmap-image #*1000
						     #*0000
						     #*0000
						     #*0000)))
    (setf (aref halftone-table 2)
	  (make-halftone :percent 12 
			 :x-image (xlib:bitmap-image #*1000
						     #*0000
						     #*0010
						     #*0000)))
    (setf (aref halftone-table 3)
	  (make-halftone :percent 18
			 :x-image (xlib:bitmap-image #*1010
						     #*0000
						     #*0010
						     #*0000)))
    (setf (aref halftone-table 4) 
	  (make-halftone :percent 25
			 :filling-style OPAL:LIGHT-GRAY-FILL
			 :x-image (xlib:bitmap-image #*1010
						     #*0000
						     #*1010
						     #*0000)))
    (setf (aref halftone-table 5) 
	  (make-halftone :percent 31
			 :x-image (xlib:bitmap-image #*1010
						     #*0100
						     #*1010
						     #*0000)))
    (setf (aref halftone-table 6) 
	  (make-halftone :percent 37
			 :x-image (xlib:bitmap-image #*1010
						     #*0100
						     #*1010
						     #*0001)))


    (setf (aref halftone-table 7) 
	  (make-halftone :percent  43
			 :x-image (xlib:bitmap-image #*1010
						     #*0101
						     #*1010
						     #*0001)))
    (setf (aref halftone-table 8) 
	  (make-halftone :percent 50
			 :filling-style OPAL:GRAY-FILL
			 :x-image (xlib:bitmap-image #*1010
						     #*0101
						     #*1010
						     #*0101)))
    (setf (aref halftone-table 9) 
	  (make-halftone :percent 56
			 :x-image (xlib:bitmap-image #*1010
						     #*0101
						     #*1010
						     #*0111)))
    (setf (aref halftone-table 10) 
	  (make-halftone :percent 62
			 :x-image (xlib:bitmap-image #*1010
						     #*1101
						     #*1010
						     #*0111)))
    (setf (aref halftone-table 11) 
	  (make-halftone :percent 68
			 :x-image (xlib:bitmap-image #*1010
						     #*1101
						     #*1010
						     #*1111)))
    (setf (aref halftone-table 12) 
	  (make-halftone :percent 75
			 :filling-style OPAL:DARK-GRAY-FILL
			 :x-image (xlib:bitmap-image #*1010
						     #*1111
						     #*1010
						     #*1111)))
    (setf (aref halftone-table 13) 
	  (make-halftone :percent 81
			 :x-image (xlib:bitmap-image #*1010
						     #*1111
						     #*1011
						     #*1111)))
    (setf (aref halftone-table 14) 
	  (make-halftone :percent 87
			 :x-image (xlib:bitmap-image #*1110
						     #*1111
						     #*1011
						     #*1111)))
    (setf (aref halftone-table 15) 
	  (make-halftone :percent 93
			 :x-image (xlib:bitmap-image #*1110
						     #*1111
						     #*1111
						     #*1111)))

    (setf (aref halftone-table 16) 
	  (make-halftone :percent 100
			 :x-image (xlib:bitmap-image #*1111
						     #*1111
						     #*1111
						     #*1111)))

    halftone-table))


;;; This used to be done by a DefVar, but now the DefVars all occur at
;;; the start of loading Opal, before the function is defined, so we must
;;; Setf it here...
(setf *halftone-table* (build-halftone-table))

#|
;; quick and dirty 
(defun find-halftone (percent halftone-table)
  (if (< percent (halftone-percent (aref halftone-table 0)))
      0
      (do ((i 1 (1+ i))
	   (tone nil))
	  ((>= i *halftone-table-size*) (1- *halftone-table-size*))
	
	;; decide which one is closer to the value desired
	(if (> (halftone-percent (setf tone (aref halftone-table i)))
	       percent)
	    (if (<= (- (halftone-percent tone) percent)
		    (- percent
		       (halftone-percent (aref halftone-table (1- i)))))
		(return-from find-halftone i)
		(return-from find-halftone (1- i)))))))
|#

;; even quicker and dirtier
(defun find-halftone (percent)
  (round (* (max 0 (min 100 percent)) (1- *halftone-table-size*)) 100))


(defun halftone-image (percent)
  (let ((halftone (aref *halftone-table*
			(find-halftone percent))))
    (values
     (halftone-x-image halftone)
     (halftone-percent halftone))))

(WITH-DEMON-DISABLED (g-value opal:GRAPHICAL-OBJECT :invalidate-demon)
	(s-value opal::WHITE-FILL-BITMAP      :image (halftone-image  0))
	(s-value opal::LIGHT-GRAY-FILL-BITMAP :image (halftone-image 25))
	(s-value opal::GRAY-FILL-BITMAP       :image (halftone-image 50))
	(s-value opal::DARK-GRAY-FILL-BITMAP  :image (halftone-image 75)))

(defun halftone-image-darker (percent)
  (let ((halftone (aref *halftone-table*
			(min (1- *halftone-table-size*)
			     (1+ (find-halftone percent))))))
    (values
     (halftone-x-image halftone)
     (halftone-percent halftone))))

(defun halftone-image-lighter (percent)
  (let ((halftone (aref *halftone-table*
			(max 0 (1- (find-halftone percent))))))
    (values
     (halftone-x-image halftone)
     (halftone-percent halftone))))

;;; This takes a list-of-lists, representing the 1's and 0's of the mask of
;;; this filling-style, and creates a filling-style with a :stipple slot set to
;;; a bitmap which has a :image slot set to the x-image resulting from this
;;; mask.

(defun make-filling-style (fname-or-image-list &key
				 (from-file-p NIL)
				 (foreground-color opal:black)
				 (background-color opal:white))
  (let ((result      (create-instance NIL opal:filling-style
		        (:foreground-color foreground-color)
			(:background-color background-color)
			(:fill-style :opaque-stippled)))
	(stipple-entry  (create-instance NIL opal:bitmap))
	(fixed-list  (unless from-file-p
			(mapcar #'(lambda(x) (coerce x 'simple-bit-vector))
			     fname-or-image-list)))
	image)
    (if from-file-p
	(if (probe-file fname-or-image-list)
	  (setq image (read-image fname-or-image-list))
	  (format t "*** Warning: could not find bitmap file ~A~%"
		  fname-or-image-list))
	(setq image (apply 'xlib:bitmap-image fixed-list)))
    (unless image
	(format t "*** Warning: making filling-style ~A with a NIL image!~%"
		result))
    (s-value stipple-entry :image image)
    (s-value result :stipple stipple-entry)
    result
  )
)
(setq opal:diamond-fill (make-filling-style '(
	(1 1 1 1 1 1 1 1 1)
	(1 1 1 1 0 1 1 1 1)
	(1 1 1 0 0 0 1 1 1)
	(1 1 0 0 0 0 0 1 1)
	(1 0 0 0 0 0 0 0 1)
	(1 1 0 0 0 0 0 1 1)
	(1 1 1 0 0 0 1 1 1)
	(1 1 1 1 0 1 1 1 1)
	(1 1 1 1 1 1 1 1 1))))
