;;; -*- 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-new.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 07/22/92 10:48:17
;;; Last Modification By: Juergen Herczeg
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(proclaim '(special canvas-window paint-menu *display* *toplevel*))

;;; 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)))

(defmethod initialize-instance :after ((self canvas) &rest args)
  (with-slots (saved-pixmap pixmap undo-pixmap width height) self
    (update-gcontext self)
    (setf pixmap (create-pixmap :width width :height height
				:depth (contact-depth (contact-root self))
				:drawable (contact-root self)))
    (setf saved-pixmap
	(create-pixmap :width width
		       :height height
		       :depth (drawable-depth (contact-root self))
		       :drawable (contact-root self)))
    (setf undo-pixmap
	(create-pixmap :width width
		       :height height
		       :depth (drawable-depth (contact-root self))
		       :drawable (contact-root self)))))
		  
(defmethod mouse-enters-action :around ((self canvas))
  (install-colormap (window-colormap self))
  (call-next-method))

(defmethod (setf painting-color) :after (value (self canvas))
  (update-gcontext self)
  (change-window-background (contact-parent self) value))

(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 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-line pixmap canvas-gc x1 y1 (1+ x1) y1)
    (draw-line self canvas-gc x1 y1  (1+ 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))
  (with-event (x y)
    (paint-line-task self x y)))

(defmethod paint-line-task ((self canvas) x1 y1)
    (dragging-mouse
	(me :x1 x1 :y1 y1 :cursor "pencil" :window self :optimize t
	 :abort-events '((:button-press :button-2 *))
	 :mouse-documentation "Abort with middle button while holding left button.")
      (:abort () (last-canvas me))
      (:before (x1 y1) (paint-point me x1 y1) )
      (:dragged (x y x1 y1) (paint-line me x1 y1 x y))))

(defmethod paint-polygon-tool ((self canvas))
  (save-canvas self)
    (with-event (x y)
    (paint-polygon-task self x y (list x y))))

(defmethod paint-polygon-task ((self canvas) x0 y0 points)
  (with-slots (canvas-gc pixmap) self
    (using-gcontext (gc :drawable self
			 :function boole-xor
			 :foreground *inversion-pixel*)
	(dragging-mouse
	    (me :x1 x0 :y1 y0 :cursor "pencil" :window self :optimize t
		:abort-events '((:button-press :button-3 *)
				(:button-press :button-2 *)) :drag nil
		:mouse-documentation
		"Specify points by pressing left button. End by pressing right button. Abort by pressing middle button")
	  (:abort (code x y)
		  (push y points) (push x points)
		  (cond ((= code 2)
		      (last-canvas me))
		    (t (draw-lines me gc points)
		       (draw-lines pixmap canvas-gc points :fill-p t)
		       (draw-lines me canvas-gc points :fill-p t))))
	  (:before ((x1 xeins) y1) (draw-line me gc x0 y0 xeins y1))
	  (:dragged (x1 y1 x y) (draw-line me gc x0 y0 x1 y1)
		    (draw-line me gc x0 y0 x y))
	  (:after (x y)
		  (push y points) (push x points)
		  (paint-polygon-task me x y points))))))


(defmethod paint-circle-tool ((self canvas))
  (multiple-value-bind (x0 y0)
      (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)))))
	  (dragging-mouse
	   (self :x1 (+ x0 30) :y1 (+ y0 30) :cursor "circle"
		 :abort-events '((:key-press  * *))
		 :mouse-documentation
		 "Specify circumscribing rectangle. Abort by pressing any key while holding right button")
	   (:abort (event-window)
		   (format t "~&Abort: ~s" event-window)
		   (my-draw-rectangle self gc x0 y0 x y))
	   (:before (x1 y1) (warp-pointer self x1 y1)
		    (my-draw-rectangle self gc x0 y0 x1 y1))
	   (:dragged ((x x2) (y y2))
		    (my-draw-rectangle self gc x0 y0 x1 y1)
		    (my-draw-rectangle self gc x0 y0 x2 y2))
	   (:after (event-window) (format t "~&After: ~s" event-window)
		   (my-draw-rectangle self gc x0 y0 x y)
		   (draw-arc self (slot-value self 'canvas-gc)
			     (min x0 x)
			     (min y0 y)
			     (abs (- x x0))
			     (abs (- y y0))
			     (- (* 2 pi))
			     (* 2  pi))))))))

(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
     (multiple-value-bind (data depth visual)
      (time (get-raw-image pixmap :x 0 :y 0 :width width :height height
		     :format :z-pixmap))
      (time (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)))))))
   (time (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)))





(setq paint-window
      (make-window 'intel-example-window
		   :x 170 :y 20 :width 500 :height 650
		   :window-icon `(intel-example-icon :parent ,icon-menu
						     :text "Paint")
		   :title "Paint"))

(setq canvas-window
    (make-window 'canvas
		 :parent paint-window
		 :x 10 :y 30 :width 480 :height 610
		 :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))
			       (:single-middle-button "Clear" (call :self clear-canvas))
			       (:double-left-button "Random color"
				(call :self new-paint-color))
				 
			       (:double-right-button "Erase color" (call :eval (setf (painting-color *self*) (background *self*))))
			       (:double-middle-button "Undo" (call :self last-canvas))
			       )))

(defmethod new-paint-color ((self contact))
  (let ((new-pixel
	 (ignoring-errors
	  (car (alloc-color (window-colormap self)
			    (make-color :red (random 1.0)
					:green (random 1.0)
					:blue (random 1.0)))))))
    (setf (painting-color self)
	(or new-pixel (random (expt 2 (contact-depth self)))))))
 

#||
(defun show-pixmap (pixmap)
  (let ((window (make-window 'bitmap-dispel :bitmap pixmap)))
    (update-state *display*)
    (process-all-events *display*)
    (format t "~&Press any key 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*)
