;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL -*-





;;; will want to do things like delete an icon, connection , ect.
(defvar command-alist `(("Place an icon on the work space" :value place-icon
			 :documentation "Place an icon on the work space")
			("Position a connection" :value position-a-connection
			 :documentation "Position a connection")
			("Add Text To Icons" :value add-text-to-icons
			 :documentation "Add text to an icon on the work space")
			("Add free text" :value add-free-text
			 :documentation "Add free text to the work space")
			("Load procedure file" :value load-procedure-file
			 :documentation "Load a procedure file")
			("Save procedure file" :value save-procedure-file
			 :documentation "Save a procedure file")))

			






(defflavor
 system-connectivity
 nil
 (tv:process-mixin
  tv:bordered-constraint-frame-with-shared-io-buffer)
 (:default-init-plist
   :expose-p t
   :activate-p t
   :save-bits ':delayed
   :process `(connectivity-initial-process)
   :panes
   `((cs-title-pane cs-title-pane)
     (cs-work-pane cs-work-pane)
     (cs-cmd-pane cs-cmd-pane))
   :constraints
   '((standard-configuration (cs-title-pane
			       cs-cmd-pane
			       cs-work-pane)
			     ((cs-title-pane 1 :lines)
			      (cs-cmd-pane :ask :pane-size)
			      (cs-work-pane :even)
			      ))))
 
 :gettable-instance-variables
 :settable-instance-variables
 :inittable-instance-variables)


(defflavor
  cs-icon-pane
	 nil
	 (tv:window)
  (:default-init-plist
    :more-p t
    :blinker-deselected-visibility
    :off
    :blinker-flavor
    'tv:rectangular-blinker
    :blinker-p
    nil
    :deexposed-typein-action
    :normal
    :deexposed-typeout-action
    :normal
    :label
    nil
    :save-bits
    t))

(defflavor
  cs-work-pane
	 nil
	 (tv:window)
  (:default-init-plist
    :more-p t
    :blinker-deselected-visibility
    :off
    :blinker-flavor
    'tv:rectangular-blinker
    :blinker-p
    nil
    :deexposed-typein-action
    :normal
    :deexposed-typeout-action
    :normal
    :label
    nil
    :save-bits
    t))


(defflavor
  cs-cmd-pane
	 nil
	 (tv:command-menu)
   (:default-init-plist
     :more-p t
     :blinker-deselected-visibility
     :on
     :blinker-flavor
     'tv:rectangular-blinker
     :blinker-p
     t
     :deexposed-typein-action
     :normal
     :deexposed-typeout-action
     :normal
     :label
     '(:string "OPERATION TO PERFORM" :font fonts:medfnt :centered)
     :save-bits
     t
     :item-list
     `,command-alist))
;;; can the blinker be made wider or do i have to make my own blinker??????



;;; Real basic sort of window, no blinker and can't be selected
(defflavor
  cs-title-pane
	 nil
	 (tv:stream-mixin
	  tv:borders-mixin
	  tv:label-mixin
	  tv:minimum-window)
  (:default-handler handle-unclaimed-messages)
  (:default-init-plist
    :blinker-p nil
    :deexposed-typeout-action
    :normal
    :label
    '(:string "DIAGRAM A PROCEDURE" :font fonts:bigfnt :centered)
    :save-bits
    t)
  )




(defun get-work-space ()
  (let ((work-pane (send connectivity-system-window :get-pane 'cs-work-pane)))
    work-pane))



(defvar unclaimed-messages nil)

;;; why doesn't this work??????????
(defun handle-unclaimed-messages (&rest all-args)
  (push all-args unclaimed-messages)
  'hello)


(defmethod (system-connectivity :after :init) (&rest ignore)
  (funcall-self :set-selection-substitute (funcall-self :get-pane 'cs-work-pane)))

(defmethod (cs-icon-pane :after :screen-manage) (&rest ignore)
    (send self :draw-self))
   

(defvar   connectivity-system-window nil)


(defun connectivity-initial-process (window)
  (let* ((work-pane (send window ':get-pane  'CS-work-PANE))
	 (terminal-io work-pane))
    (if  connectivity-system-window
	 (send   connectivity-system-window :kill))
    (setq connectivity-system-window window)
    (send window ':loop)))



(defmethod (cs-icon-pane :draw-self) ()
  (let ((icon-pane self))
    (rectangle icon-pane 100  60 80 80)
    (diamond icon-pane 100 60  260 80)
    (circle icon-pane 40 450 80)
    (oval icon-pane 60 50 700 80)))
   





(defmethod (system-connectivity :loop) ()
  (let* ((command-pane (send self ':get-pane  'CS-work-PANE))
	 (work-space (send self ':get-pane 'CS-WORK-PANE))
	 (operand nil))
    (loop for blip = (send command-pane ':any-tyi)
	  do 
	  (typecase blip
	    (list
	     (selectq (car blip)
	       (:typeout-execute)
	       ;;(apply (cadr blip) (caddr blip)))
	       (:menu  
		(let* ((item (second blip))
		       (operation (third item)))
		  (cond ((eq operation 'position-a-connection)
			 (setq operand (position-a-connection self)))
			((eq operation 'place-icon)
			 (setq operand (place-an-icon self))))
		  (format work-space "~s" operand)))
	       (:mouse-button
		(selectq operand
		  (m (rectangle work-space 100 60 (fourth blip) (fifth blip))
		     (setq operand nil))
		  (n (diamond work-space 100 60 (fourth blip) (fifth blip))
		     (setq operand nil))
		  (o (circle work-space 40 (fourth blip) (fifth blip))
		     (setq operand nil))
		  (t (format work-space "~A~A" "operand not found" operand))))
	       (t
		(format work-space "~s" blip))))
	    (t
	     (format work-space "~A" blip))))))




(defun place-an-icon (window)
  (let ((work-pane (send window :get-pane 'cs-work-pane))
        (icon (select-an-icon)))
    (when icon
      (tv:mouse-warp (// (send tv:mouse-sheet ':width) 2)
		     (// (send tv:mouse-sheet ':height) 2))
      (send work-pane :select))
    icon))


    

(defun select-an-icon  ()
  (tv:menu-choose '(("Choose an icon" :no-select nil)
		    ("m" :value m :font fonts:jamfont :documentation
		     "Process box")
		    ("n" :value n :font fonts:jamfont :documentation
		     "Decision box")
		    ("o" :value o :font fonts:jamfont :documentation
		     "Continuation")
		    ("p" :value p :font fonts:jamfont :documentation
		     "Exit"))))

 


	 
(defun position-a-connection (window)
  (let ((cs-work-pane (send window :get-pane 'cs-work-pane))
	(connection (select-a-connection)))
    (when connection
      (tv:mouse-warp (// (send tv:mouse-sheet ':width) 2)
		     (// (send tv:mouse-sheet ':height) 2))
      (send cs-work-pane :select))
    connection))


(defun select-a-connection ()
  (tv:menu-choose '(("Choose a connection to position" :no-select nil)
			    ("a" :value a :font fonts:jamfont :documentation
			     "Horizontal connection")
			    ("b" :value b :font fonts:jamfont :documentation
			     "Vertical connection")
			    ("c" :value c :font fonts:jamfont :documentation
			     "Vertical connection to left horizontal connection")
			    ("d" :value d :font fonts:jamfont :documentation
			     "Vertical connection to right horizontal connection")
			    ("e" :value e :font fonts:jamfont :documentation
			     "Left horizontal connection to vertical connection")
			    ("f" :value f :font fonts:jamfont :documentation
			     "Right horizontal connection to vertical connection")
			    ("g" :value g :font fonts:jamfont :documentation
			     "Left horizontal connection to existing vertical line")
			    ("h" :value h :font fonts:jamfont :documentation
			     "Right horizontal connection to existing vertical line")
			    ("k" :value k :font fonts:jamfont :documentation
			     "Attach connections"))))

(defflavor character-blinker
	 nil
	 (tv:character-blinker
	  tv:blinker
	  )
         (:default-init-plist
	   :font 'jamfont
	   :character 'q
	   :follow-p t
	   :visibility t))
	  
	   



  

			    
;;; The work space contains graphical objects, lines connecting them, and text.

(defvar work-space nil)


;;; x-pos and y-pos at upper left

(defun rectangle (&optional stream width height x-pos y-pos)
  (let ((stream-out (if stream stream terminal-io))
	(x0 x-pos)
	(y0 y-pos)
	(x1 (+ x-pos width))
	(y1 y-pos)
	(x2 (+ x-pos width))
	(y2 (+ y-pos height))
	(x3 x-pos)
	(y3 (+ y-pos height)))
    (send stream-out ':draw-lines  tv:alu-ior x0 y0 x1 y1 x2 y2 x3 y3 x0 y0)))

;;; x-pos and y-pos at center

(defun rectangle (&optional stream width height x-pos y-pos)
  (let* ((stream-out (if stream stream terminal-io))
	(half-width (fix (* .5 width)))
	(half-height (fix (* .5 height)))
	(x0 (- x-pos half-width))
	(y0 (- y-pos half-height))
	(x1 (+ x-pos half-width))
	(y1 (- y-pos half-height))
	(x2 (+ x-pos half-width))
	(y2 (+ y-pos half-height))
	(x3 (- x-pos half-width))
	(y3 (+ y-pos half-height)))
    (send stream-out ':draw-lines  tv:alu-ior x0 y0 x1 y1 x2 y2 x3 y3 x0 y0)))



;;; x-pos and y-pos at center
;;; THIS IS QUITE BRAIN DAMAGED, talk to bobp

(defun oval (&optional stream width height x-pos y-pos)
  (let* ((stream-out (if stream stream terminal-io))
	 (half-width (fix (* .5 width)))
	 (half-height (fix (* .5 height)))
	 (x-1 x-pos)
	 (y-1 (- y-pos half-height))
	 (x0 (- x-pos half-width))
	 (y0 (- y-pos half-height))
	 (x1 (+ x-pos half-width))
	 (y1 (- y-pos half-height))
	 (x2 (+ x-pos half-width))
	 (y2 (+ y-pos half-height))
	 (x3 (- x-pos half-width))
	 (y3 (+ y-pos half-height))
	 (x-pos-array (make-array 6))
	 (y-pos-array (make-array 6)))
    (setf (aref x-pos-array 0) x0)
    (setf (aref y-pos-array 0) y0)
    
    (setf (aref x-pos-array 1) x-1)
    (setf (aref y-pos-array 1) y-1)
    (setf (aref x-pos-array 2) x1)
    (setf (aref y-pos-array 2) y1)
    (setf (aref x-pos-array 3) x2)
    (setf (aref y-pos-array 3) y2)
    (setf (aref x-pos-array 4) x3)
    (setf (aref y-pos-array 4) y3)
    (setf (aref x-pos-array 5) x0)
    (setf (aref y-pos-array 5) y0)
    (send stream-out ':draw-cubic-spline x-pos-array y-pos-array 100)))




;;; x-pos and y-pos at center

(defun diamond (&optional stream width height x-pos y-pos)
  (let* ((stream-out (if stream stream terminal-io))
	(half-width (fix (* .5 width)))
	(half-height (fix (* .5 height)))
	(x0 (- x-pos half-width))
	(y0 y-pos)
	(x1 x-pos)
	(y1 (- y-pos half-height))
	(x2 (+ x-pos half-width))
	(y2 y-pos)
	(x3 x-pos)
	(y3 (+ y-pos half-height)))
    (send stream-out ':draw-lines  tv:alu-ior x0 y0 x1 y1 x2 y2 x3 y3 x0 y0)))



(defun circle (&optional stream radius x-pos y-pos)
  (let* ((stream-out (if stream stream terminal-io)))
    (send stream-out ':draw-circular-arc x-pos y-pos radius 0 (* 2 pi))))





(tv:add-system-key #\j 'system-connectivity "FLOW CHART")

(load "dj:bobp;jamfont")