;; -*- mode: common-lisp; package: clim-user -*-
;;
;;				-[]-
;; 
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$


(in-package :clim-user)

;;; Clim based plotting package

;;-- How does incremental redisplay fit into all of this.
;;-- What happens if we use it and redisplay is not called at the
;;-- outer level


(defmacro plotting-data ((stream &rest  options) &body body)
  ;; For each X value we want to specify the Y values
  ;; Specify labels for each X value
  ;; Specify label for each set of Y values
  ;; Specify the size of the graph we want draw.
  ;; Range of values for the axiss
  (let ((point-plotting-continuation (gensym))
	(plot-data-continuation (gensym)))
    `(flet ((plotting-data-body (,point-plotting-continuation ,plot-data-continuation) 
				;; Perhaps we can also have a way of
				;; specify all the points in one go
				(flet ((plot-point (x &rest ys)
					 (apply ,point-plotting-continuation x ys))
				       (plot-data (array)
					 (funcall ,plot-data-continuation array)))
				  ,@body)))
	   (invoke-plotting-data ,stream #'plotting-data-body ,@options))))

;; We should make presentations of these types

(define-presentation-type graph-plot ())
(define-presentation-type graph-region ())

(define-presentation-method presentation-typep (object (type graph-region))
  (typep object 'standard-rectangle))

(define-command-table plot-command-table)

(define-presentation-translator select-graph-region
    (graph-plot graph-region plot-command-table :gesture :select)
  (x y window)
  (let ((nx x)
	(ny y)
	(ox x)
	(oy y))
    (with-output-recording-options (window :record nil)
      (flet ((draw-it ()
	       (draw-rectangle* window nx ny ox oy :filled nil :ink +flipping-ink+)))
	(draw-it)
	(tracking-pointer
	 (window)
	 (:pointer-motion
	  (x y)
	  (draw-it) 
	  (setq nx x ny y)
	  (draw-it))
	 (:pointer-button-press
	  (x y)
	  (draw-it)
	  (setq nx x ny y)
	  (return (make-rectangle* ox oy nx ny))))))))

;; Define a presentation translator from a graph-plot to a graph-region.
;; In that way we trivially write a command that will zoom into a
;; particular region of the graph.

(define-presentation-type graph-point ())
(define-presentation-type graph-line ())

(define-presentation-type graph-axis ())

(defun invoke-plotting-data (stream continuation 
			     &key x-labels 
				  y-labels 
				  y-labelling
				  x-min y-min
				  x-max y-max width height)
  (let ((points nil))
    (flet ((point-collector (x &rest ys)
	     (push (list* x ys) points))
	   (plot-data-collector (data)
	     (setq points data)))
      (funcall continuation #'point-collector #'plot-data-collector))

    (etypecase points
      ((array t (* *)) nil)
      (list
       (setq points (make-array (list (length points) (length (car points)))
				:initial-contents (nreverse points)))))

    (multiple-value-setq  (width height)
      (default-width-and-height stream width height))
    
    (multiple-value-setq (x-min y-min x-max y-max y-labelling)
      (default-graph-axis points x-min y-min x-max y-max y-labelling))

    (let ((transform
	   (let ((scaling-transform
		  (make-scaling-transformation
		   (/ width (- x-max x-min))
		   (/ height (- y-max y-min)))))
	     (multiple-value-bind (ox oy)
		 (transform-position scaling-transform x-min y-min)
	       (compose-transformations
		(make-translation-transformation (- ox) (- oy))
		scaling-transform)))))
      (with-new-output-record (stream 'standard-sequence-output-record)
	(with-output-as-presentation (stream nil 'graph-plot :single-box :position)
	  (formatting-item-list (stream :n-columns 2)
	      (formatting-cell (stream)
		  (with-room-for-graphics (stream)
		    (draw-axis
		     stream 
		     width height
		     x-min y-min x-max y-max
		     x-labels 
		     y-labels
		     points
		     transform
		     y-labelling)
		    (draw-data stream width height x-min y-min x-max
			       y-max points transform)))
	    (formatting-cell (stream)
		(draw-caption stream y-labels))))))))

(defun draw-caption (stream y-labels)
  (updating-output (stream :unique-id 'captions
			   :cache-value (copy-list y-labels)
			   :cache-test #'equalp)
      (let ((n-lines (length y-labels))
	    (ascent (text-style-ascent (medium-text-style stream) stream))
	    (descent (text-style-descent (medium-text-style stream) stream))
	    (i 0))
	(surrounding-output-with-border (stream)
	    (formatting-table (stream)
		(dolist (label y-labels)
		  (formatting-row (stream)
		      (formatting-cell (stream)
			  (draw-rectangle* stream 0 0 20 (+ ascent descent) :ink +background-ink+)
			(draw-line* stream 0 (/ ascent 2) 20 (/ ascent 2)
				    :ink (make-contrasting-inks n-lines i)
				    :line-dashes (make-contrasting-dash-patterns n-lines i)))
		    (formatting-cell (stream)
			(write-string label stream)))
		  (incf i)))))))
	    

(defun draw-axis (stream width height x-min y-min x-max y-max x-labels y-labels points transform y-labelling)
  ;; Y Axis

  (updating-output (stream :unique-id 'y-axis
			   :cache-value (list width height x-min y-min
					      x-max
					      y-max y-labelling)
			   :cache-test #'equalp)
      (with-output-as-presentation (stream nil 'graph-axis)
	(draw-line* stream 0 0 0 height)
	(do ((y y-min (+ y-labelling y)))
	    ((>= y y-max))
	  (multiple-value-bind (tx ty) 
	      (transform-position transform x-min y)
	    (draw-line* stream (- tx 2) ty (+ tx 2) ty)
	    (let ((label (format nil "~3d" y)))
	      (multiple-value-bind (width height ignore-x ignore-y baseline)
		  (text-size stream label)
		(declare (ignore ignore-x ignore-y))
		(draw-text* stream label (- tx width 2) ty)))))))

  ;; X Axis labelling
  (updating-output (stream :unique-id 'x-axis
			   :cache-value (list width height x-min y-min
					      x-max
					      y-max (copy-list x-labels))
			   :cache-test #'equalp)
      (with-output-as-presentation (stream nil 'graph-axis)
	(draw-line* stream 0 0 width 0)
	(let ((i 0))
	  (dolist (label x-labels)
	    (multiple-value-bind (tx ty) 
		(transform-position transform (aref points i 0) y-min)
	      (draw-line* stream tx (- ty 2) tx (+ ty 2))
	      (multiple-value-bind (width height ignore-x ignore-y baseline)
		  (text-size stream label)
		(declare (ignore ignore-x ignore-y))
		(draw-text* stream label (- tx (/ width 2)) (- ty height 3))
		(incf i))))))))



(defun draw-data (stream width height x-min y-min x-max y-max points transform)
  (destructuring-bind
      (rows columns) (array-dimensions points)
    (let* (
	   (n-lines (1- columns)))
    
      (dotimes (i n-lines)

	(updating-output (stream :unique-id `(plot-line ,i)
				 :id-test #'equal
				 :cache-value (list x-min y-min x-max y-max width height
						    (let ((r nil))
						      (dotimes (j rows
								 (nreverse r))
							(push (aref points j 0) r)
							(push (aref points j (1+ i)) r)))))
	    (let (last-tx last-ty)
	      (with-output-as-presentation (stream (1+ i) 'graph-line)
		(draw-lines*
		 stream 
		 (let ((r nil)) 
		   (dotimes (j rows (nreverse r))
		     (let ((x (aref points j 0))
			   (y (aref points j (1+ i))))
		       (multiple-value-bind
			   (tx ty)
			   (transform-position transform x y)
			 (when last-tx 
			   (push last-tx r) 
			   (push last-ty r)
			   (push tx r)
			   (push ty r))
			 (setq last-tx tx last-ty ty)))))
		 :ink (make-contrasting-inks n-lines i)
		 :line-dashes (make-contrasting-dash-patterns n-lines i))))
      
	  (dotimes (j rows)
	    (let ((x (aref points j 0))
		  (y (aref points j (1+ i))))
	      (multiple-value-bind
		  (tx ty)
		  (transform-position transform x y)
		(with-output-as-presentation (stream (list (1+ i) j) 'graph-point)
		  (draw-circle* stream tx ty 4 :filled t))))))))))
    
(defun default-width-and-height (stream width height)
  (values 400 300))

(defun default-graph-axis (points x-min y-min x-max y-max y-labelling)
  (destructuring-bind
      (rows columns) (array-dimensions points)
    (setq x-min (aref points 0 0) x-max x-min)
    (setq y-min (aref points 0 1) y-max y-min)
    (dotimes (i rows)
      (let ((x (aref points i 0)))
	(clim-utils::minf x-min x)
	(clim-utils::maxf x-max x)
	(dotimes (j (1- columns))
	  (let ((y (aref points i (1+ j))))
	    (clim-utils::minf y-min y)
	    (clim-utils::maxf y-max y))))))
  (values x-min y-min x-max y-max
	  (or y-labelling (float (/ (- y-max y-min) 10)))))


;; Actual demo code.

(define-application-frame plot-demo ()
			  (
			   (y-labelling :initform 5)
			   (plot-data :initform #2a((1960 5 11 14)
						    (1970 8 15 16)
						    (1980 14 18 15.5)
						    (1990 19 21 15.2)
						    (2000 24 22 15.4)))
			   (x-labels :initform '("60" "70" "80" "90" "2000"))
			   (y-labels :initform  '("Mexico City" "Tokyo" "New York"))
			   )
  (:command-table (plot-demo :inherit-from (plot-command-table)))
  (:panes 
   (graph-window :application :display-function 'display-graph
		:incremental-redisplay t
		 :scroll-bars :both
		 :width :compute :height :compute)
   (data-window :application :display-function 'display-data
		:incremental-redisplay t
		:scroll-bars :both
		:width :compute :height :compute)
   (command :interactor :height '(5 :line)))
  (:layouts
   (:default (vertically () graph-window data-window command))))


(defmethod frame-standard-output ((fr plot-demo))
  (get-frame-pane fr 'command))

(define-presentation-type data-point ())
(define-presentation-type x-label ())
(define-presentation-type y-label ())

(defmethod display-data ((frame plot-demo) stream &key &allow-other-keys)
  (with-slots (y-labels x-labels plot-data) frame
    (formatting-table (stream)
	;; Headers
	(formatting-row (stream)
	    (updating-output (stream :unique-id `(-1 ,-1)
				       :id-test #'equal
				       :cache-value nil
				       :cache-test #'equalp)

	     (formatting-cell (stream) stream)) ; Dummy corner

	  (updating-output (stream :unique-id `(-1 ,0)
				   :id-test #'equal
				   :cache-value nil
				   :cache-test #'equalp)
	      (formatting-cell (stream) stream )) ; Over the X values

	  (let ((i 0))
	    (dolist (label y-labels)
	      (updating-output (stream :unique-id `(-1 ,(+ 2 i))
				       :id-test #'equal
				       :cache-value label
				       :cache-test #'equalp)
		  (formatting-cell (stream) 
		      (with-output-as-presentation (stream i 'y-label)
			(write-string label stream))))
		(incf i))))
      (destructuring-bind (rows columns)
	  (array-dimensions plot-data)
	(dotimes (i rows)
	  (let ((label (nth i x-labels)))
	    (formatting-row (stream)
		(updating-output (stream :unique-id `(,i -1)
					 :id-test #'equal
					 :cache-value label
					 :cache-test #'equalp)
		    (formatting-cell (stream)
			(with-output-as-presentation (stream i 'x-label)
			  (write-string label stream))))
	      (dotimes (j columns)
		(let ((n  (aref plot-data i j)))
		  (updating-output (stream :unique-id `(,i ,j)
					   :id-test #'equal
					   :cache-value n
					   :cache-test #'equal)
		      (formatting-cell (stream)
			  (with-output-as-presentation (stream (list i j) 'data-point)
			    (with-output-as-presentation (stream n 'number)
			      (format stream "~2D" n))))))))))))))

(define-plot-demo-command (com-edit-x-label :name t :menu t)
    ((i 'x-label :gesture :select))
  (with-application-frame (frame)
    (setf (nth i (slot-value frame 'x-labels))
      (accept 'string
	      :default (nth i (slot-value frame 'x-labels))))))

(define-plot-demo-command (com-edit-y-label :name t :menu t)
    ((i 'y-label :gesture :select))
  (with-application-frame (frame)
    (setf (nth i (slot-value frame 'y-labels))
      (accept 'string
	      :default (nth i (slot-value frame 'y-labels))))))

(define-plot-demo-command (com-edit-data-point :name t :menu t)
    ((point 'data-point :gesture :select))
  (with-application-frame (frame)
    (destructuring-bind (i j) point
      (setf (aref (slot-value frame 'plot-data) i j)
	(accept 'number
		:default (aref (slot-value frame 'plot-data) i j))))))

(defmethod display-graph ((frame plot-demo) stream &key &allow-other-keys)

  (with-slots (y-labelling plot-data x-labels y-labels) frame
    (plotting-data (stream :y-labelling y-labelling :x-labels x-labels :y-labels y-labels)
		   (plot-data plot-data))))

(define-plot-demo-command com-describe-graph-line 
    ((line 'graph-line :gesture :select))
  (describe line))

(define-plot-demo-command com-describe-graph-point
    ((point 'graph-point :gesture :select))
  (describe point))


(define-plot-demo-command (com-describe-region :name t) 
    ((region 'graph-region))
  (describe region))

(define-plot-demo-command (com-redisplay :name t) 
    ()
  (window-clear (get-frame-pane *application-frame* 'graph-window))
  (window-clear (get-frame-pane *application-frame* 'data-window)))