;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Paint Examples
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/examples/xpaint.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 08/05/92 16:12:22
;;; Last Modification By: Matthias Ressel
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(proclaim '(special demo-window icon-menu menu-window
	    menu-1 menu-2 menu-3 menu-4 menu-5 menu-6 menu-7
	    menu-8 *display* *toplevel*))

;(pmds::load-system :xit-color-sheet)
(defvar *xpaint-color-sheet* (make-color-sheet *toplevel*
				      :window-editable? nil
				      :menu-editable? nil))

;;; Mouse tracking

(defmacro grabbing-the-mouse ((grab-window  &key (x0 0) (y0 0) (x1 x0) (y1 y0)
						 (cursor "cross")
						(drag t) optimize
						confine-window) 
			      &rest clauses)
  (unless (every #'(lambda (clause) (and (listp clause)
					 (member (car clause) '(:before
								:during
								:after))))
		 clauses)
    (error "Grabbing-the-mouse clauses do not all begin with one of ~%~
 the keywords :before, :during, or :after."))
  (flet ((make-lambda-form (key args)
   (let ((clause (car (member key clauses :key 'car))))
     (cond ((null clause)
	    `(function (lambda (&rest args)
		(declare (ignore args))
		nil)))
	   ((listp (cadr clause))
	    `(function (lambda ,args
	       ,.(cdr clause))))
	   (t `(function ,(cdr clause)))))))
    (let ((window-var (gensym)))
    `(let ((,window-var ,grab-window))
       (grab-the-mouse ,window-var ,x0 ,y0 ,x1 ,y1
		       ,(make-lambda-form :before '(window x0 y0 x1 y1))
		       ,(make-lambda-form :during '(window x0 y0 x1 y1 x2 y2))
		       ,(make-lambda-form :after '(window x0 y0 x1 y1 last-event-window))
		       :cursor ,cursor
		       :drag ,drag
		       :optimize ,optimize
		       :confine-window ,confine-window)))))

#||
(defun test-grab ()
  (let ((test "HAllo"))
   (grabbing-the-mouse (pi) (:before (print test)))))

(defun grab-the-mouse (win x0 y0 x1 y1 action1 &rest args)
  (funcall action1 win x0 y0 args))
||#

(defmethod grab-the-mouse ((grab-window contact) x0 y0 x1 y1 action1 action2 action3
			   &key (cursor "cross") (drag t) optimize confine-window)
    (let ((last-event-window nil))
    (with-slots (parent display) grab-window
      (unwind-protect
	  (ignoring-errors
	   (cond ((eq :success 
		   (grab-pointer grab-window
				 (list (if drag :button-release
					 :button-press) :pointer-motion) 
				 :owner-p T
				 :confine-to (or confine-window grab-window)
				 :cursor (convert grab-window cursor 'cursor)
				 :time nil))
	     (funcall action1 grab-window x0 y0 x1 y1)
	     (event-case (display :discard-p T 
			:force-output-p t)
	       (motion-notify (x y event-window)
		 (unless (and optimize (discard-but-last-motion-event
					grab-window
					(list (if :drag :button-release :button-press))))
		   (multiple-value-bind (x2 y2)
		       (contact-translate event-window x y grab-window)
		     (funcall action2 grab-window x0 y0 x1 y1 x2 y2)
		   ;; make the new position the current position
		     (setq x1 x2
			   y1 y2))
		   )
	       nil)
	     (button-press (event-window)
		 (unless drag
		   (setq last-event-window event-window)
		   t))
	     (button-release (event-window)
		 (when drag
		   (setq last-event-window event-window)
		   t)))
	     (funcall action3 grab-window x0 y0 x1 y1 last-event-window))
		 (t (format t "~&Fehler beim Grabbing.~&")
		    (force-output))))
	   (ungrab-pointer display)
	   ))))


#||
(defcontact mouse-tracking-mixin ()
  ())

(defmethod track-mouse ((confine-window mouse-tracking-mixin)
			&rest args &key drag discard)
  (with-event (x y event-window)
    (unless event-window (setq event-window confine-window))
    (multiple-value-bind (x-new y-new)
	(contact-translate event-window x y confine-window)
      (apply #'track-mouse-aux confine-window x-new y-new args))))

(defmethod track-mouse-aux ((confine-window mouse-tracking-mixin)
			    x-old y-old &key drag discard)
  (with-slots (parent display) confine-window
    (unwind-protect
	(ignoring-errors
	 (when (eq :success 
		   (grab-pointer parent
				 (list (if drag :button-release
					 :button-press) :pointer-motion) 
				 :owner-p T
				 :confine-to confine-window
				 :cursor (convert confine-window "fleur" 'cursor)
				 :time nil))
	   (event-case (display :discard-p T 
			:force-output-p t)
	     (motion-notify (x y event-window)
		 (unless (and discard (discard-but-last-motion-event
				       confine-window
				       (list (if :drag :button-release :button-press))))
		   (multiple-value-bind (x-new y-new)
		       (contact-translate event-window x y confine-window)
		     (track-mouse-notify confine-window x-old y-old x-new y-new)
		   ;; make the new position the current position
		     (setq x-old x-new
			   y-old y-new))
		   )
	       nil)
	     (button-press ()
		 (unless drag
		   t))
	     (button-release ()
		 (when drag
		   t)))))
	   (ungrab-pointer display))))

(defmethod track-mouse-notify ((self mouse-tracking-mixin) x-old y-old x y)
  nil)
||#
;;; Canvas

(defcontact canvas (bitmap-dispel)
  ((painting-color :accessor painting-color :type string :initform "blue")
   (painting-width :accessor painting-width :initform 10)
   (canvas-gc :initform nil)
   (painting-function :initform 'paint-line :documentation "Takes arguments canvas x1 y1 x2 y2")
   (background :initform "white")
   (saved-pixmap :type (or null pixmap) :initform nil)
   (undo-pixmap :type pixmap :initform nil)
   (width :initform 400) (height :initform 600)
   (display-position :initform :upper-left)))

(defmethod initialize-instance :after ((self canvas) &rest args)
  (with-slots (saved-pixmap pixmap undo-pixmap width height) self
    (update-gcontext self)
    (cond ((bitmap self)
	   (update-pixmap self))
	  (t 
	   (setf pixmap (create-pixmap :width width :height height
				:depth (contact-depth (contact-root self))
				:drawable (contact-root self)))
	   (update-other-pixmaps self)))))

(defmethod update-pixmap :after ((self canvas))
  (update-other-pixmaps self))

(defmethod update-other-pixmaps ((self canvas))
  (with-slots (pixmap saved-pixmap undo-pixmap) self
  (let ((width (drawable-width pixmap))
	(height (drawable-height pixmap))
	(depth (drawable-depth pixmap))
	(drawable (contact-root self)))
    (when saved-pixmap (free-pixmap saved-pixmap))
    (setf saved-pixmap
	(create-pixmap :width width :height height
		       :depth  depth :drawable drawable))
    (when undo-pixmap (free-pixmap undo-pixmap))
    (setf undo-pixmap
	(create-pixmap :width width :height height
		       :depth depth :drawable drawable)))))
  
		  
(defmethod (setf painting-color) :after (value (self canvas))
  (update-gcontext self)
  (setf (background (part (part (part-of self) :randomColor) :text)) value))

(defmethod (setf painting-width) :after (value (self canvas))
  (update-gcontext self))

(defmethod update-gcontext ((self canvas))
  (with-slots (canvas-gc painting-color painting-width) self
    (using-gcontext (gc  :drawable (contact-root self)
			 :background (background self)
			 :foreground (convert self painting-color 'pixel)
			 :line-width painting-width
			 :join-style :round
			 :cap-style :round)
      (setf canvas-gc gc))))

(defmethod track-mouse-notify ((self canvas) x1 y1 x2 y2)
  (with-slots (painting-function) self
    (funcall painting-function self x1 y1 x2 y2)))


(defmethod save-canvas ((self canvas))
  (with-slots (saved-pixmap pixmap width height) self
    (using-gcontext (gc :drawable self)
      (copy-area pixmap gc 0 0 width height saved-pixmap 0 0))))

(defmethod last-canvas ((self canvas))
  (with-slots (saved-pixmap pixmap undo-pixmap width height) self
    (using-gcontext (gc :drawable self)
      (copy-area saved-pixmap gc 0 0 width height undo-pixmap 0 0))
    (using-gcontext (gc :drawable self :function boole-xor)
      (copy-area pixmap gc 0 0 width height undo-pixmap 0 0)
      (copy-area undo-pixmap gc 0 0 width height pixmap 0 0)
      (copy-area undo-pixmap gc 0 0 width height saved-pixmap 0 0)
      (update self))))

(defmethod clear-canvas ((self canvas))
  (save-canvas self)
  (with-slots (background width height pixmap) self
    (using-gcontext (gc :drawable self
		      :foreground background)
      (draw-rectangle pixmap gc 0 0 width height t)
      (update self))))

(defmethod paint-point ((self canvas) x1 y1)
  (with-slots (canvas-gc pixmap) self
    (draw-point pixmap canvas-gc x1 y1)
    (draw-point self canvas-gc x1 y1)
    ))
    

(defmethod paint-line ((self canvas) x1 y1 x2 y2)
  (with-slots (canvas-gc pixmap) self
    (draw-line pixmap canvas-gc x1 y1 x2 y2)
    (draw-line self canvas-gc x1 y1 x2 y2)
    ))

(defmethod paint-line-tool ((self canvas))
  (multiple-value-bind (x y)
      (query-pointer self)
    (grabbing-the-mouse
     (self :cursor "pencil" :x0 x :y0 y)
     (:before (paint-point window x0 y0))
     (:during (paint-line window x1 y1 x2 y2))
     )))

(defmethod paint-circle-tool ((self canvas))
  (multiple-value-bind (x y)
      (query-pointer self)
     (using-gcontext (gc :drawable self
			 :function boole-xor
			 :foreground *inversion-pixel*)
       (flet ((my-draw-rectangle (window gc x0 y0 x1 y1)
		(draw-rectangle window gc (min x0 x1)(min y0 y1)
				    (abs (- x1 x0)) (abs  (- y1 y0)))))
       (grabbing-the-mouse
	   (self :cursor "circle" :x0 x :y0 y :x1 (+ x 30) :y1 (+ y 30))
	   (:before (warp-pointer window x1 y1)
		    (my-draw-rectangle window gc x0 y0 x1 y1))
	   (:during (my-draw-rectangle window gc x0 y0 x1 y1)
		    (my-draw-rectangle window gc x0 y0 x2 y2))
	   (:after (my-draw-rectangle window gc x0 y0 x1 y1)
		   (paint-ellipse window x0 y0 x1 y1)))))))

(defmethod paint-ellipse ((self canvas) x0 y0 x1 y1)
  (with-slots (canvas-gc) self
    (let ((xmin (min x0 x1)) (ymin (min y0 y1))
			     (width (abs (- x1 x0))) (height (abs (- y1 y0)))
			     (pi2 (* 2 pi)))
      (draw-arc (pixmap self) canvas-gc xmin ymin width height (- pi2) pi2)
      (draw-arc self canvas-gc xmin ymin width height (- pi2) pi2))))
    

(defmethod write-canvas-file ((self canvas) pathname &optional name)
  (with-slots (height width pixmap) self
  (let ((image (get-image pixmap :x 0 :y 0 :width width :height height
			  )))
    (write-bitmap-file pathname image name))))

(defmethod read-canvas-file ((self canvas) pathname)
  (setf (bitmap self) (read-bitmap-file pathname))
  (with-slots (bitmap) self
    (setf bitmap nil)))

;;; Simple benchmarks on diabolo with 'time', bitmap druid999:
;;; read und write-canvas-file-2 takes
;;; with compiled bitmap (fasl:    200ms,  1095 conses, 2 symbol,  51744 other 
;;; with uncompiled bitmap (xcf): 2250ms, 29080 conses, 1 symbol, 943704 others
;;; read und write-canvas-file takes
;;; with xbm format (xbm):         800ms, 24236 conses, 0 symbols, 11104 others

(defmethod write-canvas-file-2 ((self canvas) pathname)
   (with-slots (height width pixmap) self
     (let ((data-array (make-array (list (* (+ 10 width) (+ 10 height)
					    (max  1 (floor (contact-depth self) 8))))
				   :element-type 'card8)))
     (multiple-value-bind (data depth visual)
      (get-raw-image pixmap :data data-array :x 0 :y 0 :width width :height height
		     :format :z-pixmap)
      (with-open-file (stream pathname :direction :output :if-exists :supersede)
	 (format stream "(in-package :xit)~
                         (defun read-canvas-file-image ()~
                            (create-image :data (coerce ~s '(array card8)) ~
                                          :width ~s :height ~s :depth ~s ~
                                          :bytes-per-line ~s))"
		 data width height depth
		 (* depth (floor (+ (1- depth) width) depth)))))))
   (compile-file pathname)
      )
      
#||
(defmethod write-canvas-file-2 ((self canvas) pathname)
   (with-slots (height width pixmap) self
     (let* ((Image (get-image pixmap :x 0 :y 0 :width width :height height
			  :result-type 'image-z))
	    (pixarray (image-z-pixarray image))
	    (*print-array* t))
       (with-open-file (stream pathname :direction :output :if-exists :supersede)
	 (format stream "(in-package :xit)~
                         (defun read-canvas-file-image ()~
                            (create-image :data (coerce ~s 'pixarray)))" pixarray))
       ;(compile-file pathname)
       )))
||#

(defmethod read-canvas-file-2 ((self canvas) pathname)
  (load pathname)
  (format t "~&File loaded~&")
  (setf (bitmap self) (read-canvas-file-image))
  (with-slots (bitmap) self
    (setf bitmap nil)))

(defmethod write-canvas-file-3 ((self canvas) pathname)
  (with-slots (height width pixmap) self
    (with-progress-indicator (:ticks height)
     (write-pixmap-file pathname (get-image pixmap :x 0 :y 0 :width width :height height
			  :result-type 'image-z)
			(window-colormap self)))))


(defmethod read-canvas-file-3 ((self canvas) pathname)
  (multiple-value-bind (image colormap)
      (with-progress-indicator ()
	(read-pixmap-file pathname 
			self :verbose nil))
    (setf (bitmap self) image)
    (setf (window-colormap self) colormap)))


(defcontact paint-example-window (paned-window intel-example-window)
  ())

(defcontact canvas-button (soft-button)
  ())

(define-resources
  (* canvas-button cursor) "hand2"
  (* canvas-button :text background) "white"
  (* canvas-button :text font) '(:face :normal :size 12)
  )

(defmethod view-of ((self canvas-button))
  (part (part-of self) :canvas))

(defmethod random-color ((self canvas))
  (setf (painting-color self) (random (expt 2 (contact-depth self)))))

(defmethod choose-color ((self canvas))
  (setf (painting-color self)
      (specify-color-value *xpaint-color-sheet*
			   :initial-value (painting-color self)
			   :colormap (window-colormap self))))

(defmethod erase-color ((self canvas))
  (setf (painting-color self)(background self)))

(defmethod write-canvas ((self canvas))
  (write-canvas-file-3 self (text (part (part-of self) :filename))))

(defmethod read-canvas ((self canvas))
  (read-canvas-file-3 self (text (part (part-of self) :filename))))

;;; extension for shell windows

(defun make-other-toplevel (&key (display *display*)
			   (shell-class 'top-level-shell)
			   (shell-title "XIT Toplevel")
			   (toplevel-class 'toplevel-window)
			   shell-init-list
			   toplevel-init-list)
  (declare (special *display* ))
  (let ((shell (apply #'make-contact shell-class
			      :parent display			
			      :width 10 :height 10 ; don't know if necessary
			      :wm-protocols-used '(:wm_take_focus
						   ;; :wm_save_yourself
						   :wm_delete_window) 
			      :wm-keyboard-input :on
			      :wm-title shell-title
			      :wm-icon-title shell-title
			      shell-init-list)))
  (apply #'make-contact toplevel-class
	 :parent shell toplevel-init-list)))

(defcontact intel-example-shell (window-icon-mixin top-level-shell)
  ())

(defmethod toplevel-window (self)
  nil)

(defcontact intel-example-toplevel (intel toplevel-window)
  ((background :initform "white")
   (reactivity :initform '((:double-left-button "Shrink to icon"
						(call :self shrink))))))

(defmethod shrink ((self intel-example-toplevel))
  (shrink (contact-parent self)))

(defmethod adjust-window-size ((self intel-example-shell))
  (with-slots (cluei::children) self
    (let ((toplevel (car cluei::children)))
    (change-geometry self :width (contact-width toplevel)
		     :height (contact-height toplevel)))))

;;; Define Paint application in own window

(setq paint-window
    (make-other-toplevel :shell-class 'intel-example-shell
			 :shell-title "Paint"
			 :toplevel-class 'intel-example-toplevel
     :shell-init-list
     `(:window-icon (intel-example-icon :parent ,icon-menu
						     :text "Paint"))))


;; Never evaluate this while the event-loop is running, you first have
;; to evaluate the succeeding expression, too:
(setq paint-paned-window
    (make-window 'paned-window
		 :adjust-size? t
		 :parent paint-window
		 :y 0
		 :border-width 0
		 :width 500 :height 650
		   :parts
		   '((:class canvas :name :canvas
		     :bitmap "sunset-small"
		     :x 10 :y 30 :width 480 :height 550
		     :adjust-size? t
		     :border-width 2
		     :reactivity ((:single-left-button "Draw line"
						       (call :self save-canvas)
						       (call :self paint-line-tool))
				  (:single-right-button "Draw circle"
							(call :self save-canvas)
							(call :self paint-circle-tool))))
		     (:class text-dispel :name :FileName
		      :border-width 1 :display-position :upper-left
		      :reactivity ((:edit
				    "Edit Filename for Loading or Saving."
				    (call :self edit-text))))
		     (:class canvas-button :name :ReadCanvas :text-part (:text "Read Canvas")
		      :bitmap-part (:bitmap "button-ml")
		      :action (call :view-of read-canvas) :action-docu "Read Canvas")
		     (:class canvas-button :name :WriteCanvas :text-part (:text "Write Canvas")
		      :bitmap-part (:bitmap "button-ml")
		      :action (call :view-of write-canvas) :action-docu "Write Canvas")
		     (:class canvas-button :name :RandomColor :text-part (:text "Random Color")
				:bitmap-part (:bitmap "button-ml")
		      :action (call :view-of random-color) :action-docu "Random color")
		     (:class canvas-button :name :ChooseColor :text-part (:text "Mix Color")
				:bitmap-part (:bitmap "button-ml")
		      :action (call :view-of choose-color) :action-docu "Mix color ")
		     (:class canvas-button :name :ClearColor :text-part (:text "Clear Color")
				:bitmap-part (:bitmap "button-ml")
		      :action (call :view-of erase-color)
				:action-docu "Erase color")
		     (:class canvas-button :name :Undo :text-part (:text "Undo")
		      :bitmap-part (:bitmap "button-m")
				:action (call :view-of last-canvas)
				:action-docu "Undo")
		     (:class canvas-button :name :ClearCanvas :text-part (:text "Clear Canvas")
				:bitmap-part (:bitmap "button-ml")
		      :action (call :view-of clear-canvas)
				:action-docu "Clear Canvas")
		     (:class text-switch
		      :name :line-width
		      :width 50 :height 50
		      :inside-border 15
		      :part-font (:face :bold :size :huge)
			:reactivity-entries
			    ((:single-left-button
			 "Change line width of canvas (switch forward)"
			       (call :self switch-forward))
			      (:single-right-button
			 "Change line width of canvas (switch backward)"
			       (call :self switch-backward))
			      (:write-event
			       (call :eval (setf (painting-width (view-of *self*))
					       (value *self*))))
			      (:read-event
			       (call :eval
				     (setf (value *self*)
				       (painting-width (view-of *self*)))))
			      (:shift-left-button "Update selection"
			       (call :read)))
			       :selection 1
			    :parts ((:view-of 0 :text "0")
				    (:view-of 1 :text "1")
				    (:view-of 2 :text "2")
				    (:view-of 3 :text "3")
				    (:view-of 4 :text "4")
				    (:view-of 5 :text "5")
				    (:view-of 6 :text "6")
				    (:view-of 7 :text "7")
				    (:view-of 8 :text "8")
				    (:view-of 9 :text "9")
				    (:view-of 10 :text "10"))))
		   :layouter
		   '(pane-layouter
		     :configurations
		     ((:config1
		       ((file (:ask :ReadCanvas) :h
			(:filename 200)
			(space 20)
			(:readCanvas :ask)
			(space 10)
			(:WriteCanvas :ask))
		       (space 5)
		       (canvas-strip (:ask :canvas) :h
			  (:canvas :ask) (space 10) (:line-width :ask))
		       (space 10)
		       (buttons (:ask :RandomColor) :h
			(:ChooseColor :ask)
			(space 10)
			(:RandomColor :ask)
			(space 10)
			(:ClearColor :ask)
			(space 50)
			(:Undo :ask)
			(space 10)
			(:ClearCanvas :ask))
		       (space 20))))
		     :configuration :config1)))

(setf (view-of (part paint-paned-window :line-width))
    (part paint-paned-window :canvas))
			    

#||
(defun show-pixmap (pixmap)
  (let ((window (make-window 'bitmap-dispel :bitmap pixmap)))
    (update-state *display*)
    (process-all-events *display*)
    (format t "~&Press <Return> to get rid of this window.~&")
    (read-char)
    (destroy window)))
||#
				   
				   
(update-state *display*)
(process-all-events *display*)

(shrink paint-window)

(update-state *display*)
(process-all-events *display*)
