;;; -*- Mode: Lisp -*-
;;; 
;;; $Id: show-tree.lsp,v 1.10.1.21 1996/05/08 12:57:10 pierpa Exp $
;;; 
;;; A Notice From Our Legal Department:
;;;
;;; ****************************************************************
;;; 
;;; Copyright (C) 1995 Pierpaolo Bernardi.
;;; 
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;; 
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; You may have received a copy of the GNU General Public License
;;; along with this program; If not, look in your disk. It's a huge
;;; file named COPYING. if you don't find it, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; 
;;; ****************************************************************
;;; 
;;; This is a program for drawing trees using Clisp with stdwin.
;;; You must have a Clisp binary linked with stdwin to use it.
;;; 
;;; WARNING:
;;; 
;;;   The *-ARC functions in Clisp's interface to Stdwin are broken in
;;;   versions up to 1995-04-25.  If your Clisp is older than this, you
;;;   should update.  Otherwise, if you try to use LineStyles other
;;;   than Bus or Segment, you lose.
;;; 
;;; SYNTAX:
;;;
;;;   show-tree is-leaf-p branches label
;;;             tree
;;;             &key style
;;;                  title
;;;                  font
;;;                  horizontal
;;;                  vertical
;;;                  shadow
;;;                  hsize
;;;                  vsize
;;;                  window-pos
;;;                  handle-events
;;; 
;;; 
;;; DESCRIPTION:
;;; 
;;;   is-leaf-p, branches and label are functions which describe the
;;;   tree.  They all take a tree as argument.
;;;   is-leaf-p   must return true if the tree is a leaf;
;;;   branches    must return a list of trees: the first level of branches
;;;               of the tree.  It will be called only on trees for which
;;;               is-leaf-p returned nil. The list will not be modified.
;;;   label       must return a string, which will be used as the label of
;;;               the node.  The string will not be modified.
;;;   
;;;   This stuff should have been done using generic functions, of course.
;;;   
;;;   keys:
;;;     style must be one of :Segments, :Bus (default), :Round-Bus,
;;;           :Barrel-arcs, :Cushion-Arcs or :Mixed-Arcs.
;;;     See the examples for their effects.
;;;     
;;;     horizontal and vertical correspond to the menu "Spaces".
;;;     See the examples for their effects.
;;;     
;;;     hsize and vsize are the initial sizes of the window.
;;;     
;;;     shadow can be:
;;;       - an integer which specifies the depth of the shadow;
;;;       - nil, same as 0;
;;;       - neither of these, uses the value of
;;;         show-tree::*default-shadow-depth*.
;;;     
;;;     window-pos must be one of :Top (default), :Bottom, :Center,
;;;       :Root, (:XY x y).
;;;       It's the initial position of the tree inside the window.
;;;     
;;;     handle-events - a boolean, default is true.
;;;       If true, show-tree does not return until the X/Close menu
;;;         item is selected.
;;;       If false, show-tree returns immediately.  Events should
;;;         be handled separately (see handle-events).
;;;     
;;;     The other parameters have the obvious meaning, once again
;;;     see the examples for their effects.
;;;   
;;;   The drawing may be panned either using the scroll bars, or by
;;;   clicking into the window and dragging.
;;; 
;;; 
;;; SYNTAX:
;;; 
;;;   handle-events &key until-shutdown
;;; 
;;; 
;;; DESCRIPTION
;;; 
;;;   keys:
;;;     until-shutdown - a boolean, default false.
;;;       If true, handle-events returns only when all the windows
;;;         created by show-tree are destroyed.
;;;       If false, handle-events will handle all pending events
;;;         and then return.
;;;
;;;  handle-events returns t if there are no show-tree windows left
;;;  on the screen. Nil, otherwise.
;;; 
;;; 
;;; BUGS:
;;; 
;;;   (The X port of) Stdwin has a limit on the size of the document it
;;;   can display in a window.  If this limit is exceeded, parts of the
;;;   drawing will overlap, and other unpleasant things may happen.
;;;   This is a design choice of (the X port of) Stdwin, which is not
;;;   easy to work around.
;;;   
;;;   When using LineStyles other than Bus or Segment, drawing is slow.
;;;   
;;;   If this program were intended to be shown to others, probably
;;;   would have nice, meaningful identifiers with long names in english.
;;;   As it is, it has short, crufty names in italenglish, except for
;;;   interface identifiers.  Sorry.
;;;   
;;; ================================================================
;;; 
;;; If you use this program, I'd love to hear from you what is being
;;; used for.  Any comment, bug-fixes or enhancements, are welcome.
;;; I can be reached at bernardp@cli.di.unipi.it
;;; 
;;; Enjoy.
;;; 

(provide :show-tree)

;;(require :isw "~/lisp/isw")

(defpackage "SHOW-TREE"
  (:use "CL" #|"ISW"|#)
  (:import-from "STDWIN"
    "ACTIVE-WINDOW" "BEGIN-DRAWING" "CHAR-WIDTH"
    "DEFAULT-WINDOW-POSITION" "DEFAULT-WINDOW-SIZE" "DONE" "DRAW-ARC"
    "DRAW-BOX" "DRAW-CHAR" "DRAW-CIRCLE" "DRAW-LINE" "DRAW-TEXT"
    "DRAWING" "DRAWPROC-ALIST" "END-DRAWING" "ERASE" "FILL-ARC"
    "FILL-CIRCLE" "GET-EVENT" "GET-EVENT-NO-HANG" "INIT" "INVERT"
    "LINE-HEIGHT" "MENU-ADD-ITEM" "MENU-ATTACH" "MENU-CREATE" "MENU-DELETE"
    "MENU-DETACH" "MENU-ITEM-DISABLE" "MENU-ITEM-ENABLE" "MENU-SIZE"
    "PAINT" "SCREEN-SIZE" "SCROLLBAR-P" "SET-ACTIVE-WINDOW"
    "SET-DEFAULT-WINDOW-POSITION" "SET-DEFAULT-WINDOW-SIZE"
    "SET-MENU-ITEM-CHECKMARK" "SET-MENU-ITEM-LABEL" "SET-SCROLLBAR-P"
    "SET-TEXT-FONT" "SET-WINDOW-CURSOR" "SET-WINDOW-DOCUMENT-SIZE"
    "SET-WINDOW-ORIGIN" "SET-WINDOW-TITLE" "SHADE" "TEXT-BREAK"
    "TEXT-WIDTH" "USER-ASK" "USER-MESSAGE" "WCLOSE" "WINDOW-CHANGE"
    "WINDOW-DOCUMENT-SIZE" "WINDOW-ORIGIN" "WINDOW-POSITION"
    "WINDOW-SHOW" "WINDOW-SIZE" "WINDOW-TITLE" "WINDOW-UPDATE" "WOPEN"
    "XOR-ARC" "XOR-CIRCLE" "XOR-LINE")
  (:export "SHOW-TREE" "HANDLE-EVENTS")
    )

(in-package "SHOW-TREE")

(eval-when (eval load compile)
  (defconstant WE-NULL         0)	; (Used internally)
  (defconstant WE-ACTIVATE     1)	; Window became active
  (defconstant WE-CHAR         2)	; Character typed at keyboard
  (defconstant WE-COMMAND      3)	; Special command, function key etc.
  (defconstant WE-MOUSE-DOWN   4)	; Mouse button pressed
  (defconstant WE-MOUSE-MOVE   5)	; Mouse moved with button down
  (defconstant WE-MOUSE-UP     6)	; Mouse button released
  (defconstant WE-MENU         7)	; Menu item selected
  (defconstant WE-SIZE         8)	; Window size changed
  (defconstant WE-MOVE         9)	; Window moved (reserved)
  (defconstant WE-DRAW         10)	; Request to redraw part of window
  (defconstant WE-TIMER        11)	; Window's timer went off
  (defconstant WE-DEACTIVATE   12)	; Window became inactive
  (defconstant WE-EXTERN       13)	; Externally generated event (Amoeba)
  (defconstant WE-KEY          14)	; Non-ascii key event
  (defconstant WE-LOST-SEL     15)	; Lost selection
  (defconstant WE-CLOSE        16)	; User wants to close window
  )

;;; Data structures used here are circular. If you are going
;;; to peek inside, remember to uncomment the following.
;;(setf *print-circle* t)

#| Tests
(eval-when (load eval compile)
  (require 'xref))

(defvar xx)
(defvar yy)

(defun prova ()
  (xref:xref-files (lisp:directory "/usr/local/clisp/src/*.lsp"))
  (setf xx (xref:make-caller-tree))
  (setf yy (list (list "radice" xx)))
  t)


(defvar xxx)

(defun prova2 ()
  (xref:xref-file "~/lisp/show-tree.lsp")
  (setf xxx (xref:make-caller-tree))
  t)

(defvar xxxx)

(defun prova3 ()
  (xref:xref-file "~/lisp/ugly-printer/uprint.lsp")
  (setf xxxx (xref:make-caller-tree))
  t)

|#

(defstruct nodo
  (etichetta 'NO-BUONO)
  (figli     'NO-BUONO)
  (padre     'NO-BUONO)
  (pos-h1    'NO-BUONO)
  (pos-v1    'NO-BUONO)
  (pos-h2    'NO-BUONO)
  (pos-v2    'NO-BUONO)
  (larghezza 'NO-BUONO)
  (altezza   'NO-BUONO)
  (pos-radice-v1 'NO-BUONO)
  (pos-radice-v2 'NO-BUONO)
  ;;(pos-radice-h2 'NO-BUONO)
  (pos-radice-coll 'NO-BUONO)
  (num-leaves 'NO-BUONO)
  (num-internal-nodes 'NO-BUONO)
  (rev-depth 'NO-BUONO)
  )

#|

   h1            larghezza
 v1+----------------------------------------------+
   |                                         dfg  |
   |                                      dfg   dg|
   |               fgdfgdfg             fg        |
   |       /dfgdfgd        dfgdfgd    gd          |
   |   h2 /                       fgdf            |
vr1+---+ /                                        |
vrc|FOO+-\                                    as  |
vr2+---+  \                                asd    | altezza
   |       \asdf                   fasd asd       |
   |            asdfas          asd    fasd       |
   |                  dfas    df           fa     |
   |                      dfas               sdf  |
   |                                            as|
   |                                              |
   |                                              |
 v2+----------------------------------------------+

|#

;;; Converts the tree ALBERO using the IS-LEAF-P BRANCHES and LABEL
;;; functions to the representation using the defstruct nodo.
;;; This representation contains both tree-shape information and
;;; node positioning info.

(defun misura (is-leaf-p branches label
	       albero padre h v spazio-orizzontale spazio-verticale font)
  (set-text-font font 0 20)
  (let* ((amp-v (+ 2 (line-height)))
	 (amp-v/2 (round amp-v 2))
	 )
    (labels ((rmisura (albero padre h v)
	       (let* ((etic (funcall label albero))
		      (amp-h (+ 5 (text-width etic))))		     
		 (cond ((funcall is-leaf-p albero)
			(make-nodo :etichetta etic
				   :figli nil
				   :padre padre
				   :larghezza amp-h
				   :altezza amp-v
				   :pos-h1 h
				   :pos-v1 v
				   :pos-h2 (+ h amp-h)
				   :pos-v2 (+ v amp-v)
				   :pos-radice-v1 v
				   :pos-radice-v2 (+ v amp-v)
				   :pos-radice-coll (+ v (ceiling amp-v 2))
				   :num-leaves 1
				   :num-internal-nodes 0
				   :rev-depth 0
				   ))
		       (t ;; (not (is-leaf-p albero))
			(let ((risposta (make-nodo :etichetta etic
						   :padre padre
						   :pos-h1 h
						   :pos-v1 v
						   :pos-h2 (+ h amp-h)
						   :pos-v2 (+ v amp-v)
						   )))
			  (let ((nh (+ h
				       (+ 2 (text-width (nodo-etichetta risposta)))
				       spazio-orizzontale))
				(nv v))
			    (setf (nodo-figli risposta)
				  (mapcar (lambda (sotto-albero)
					    (let ((risp (rmisura
							 sotto-albero
							 risposta
							 nh nv)))
					      (setf nv (+ nv
							  (nodo-altezza risp)
							  spazio-verticale))
					      risp))
					  (funcall branches albero)))
			    (decf nv spazio-verticale)
			    
			    (let ((larghezza 0)
				  (num-leaves 0)
				  (num-internal-nodes 0)
				  (rev-depth 0)
				  )
			      (dolist (f (nodo-figli risposta))
				(setf larghezza (max larghezza (nodo-larghezza f)))
				(incf num-leaves (nodo-num-leaves f))
				(incf num-internal-nodes (nodo-num-internal-nodes f))
				(setf rev-depth (max rev-depth (nodo-rev-depth f)))
				)
			      (setf (nodo-larghezza risposta) (+ 1 (- (+ nh larghezza)
								      h)))
			      (setf (nodo-num-leaves risposta) num-leaves)
			      (setf (nodo-num-internal-nodes risposta) (+ 1 num-internal-nodes))
			      (setf (nodo-rev-depth risposta) (+ 1 rev-depth))
			      )
			    
			    (setf (nodo-altezza risposta)
				  (- (+ nv spazio-verticale)
				     v))
			    (let* ((rad-coll (round (+ v nv)
						    2))
				   (rad-1 (- rad-coll amp-v/2))
				   (rad-2 (+ rad-1 amp-v)))
			      (setf (nodo-pos-radice-v1 risposta) rad-1)
			      (setf (nodo-pos-radice-v2 risposta) rad-2)
			      (setf (nodo-pos-radice-coll risposta) rad-coll)
			      risposta))))))))
      (rmisura albero padre h v))))

#|
;;; For debugging 
(defun scrivi-nodo (n)
  (format t "~&nodo ~A; h1 v1 h2 v2: ~A ~A ~A ~A  radice: ~A ~A ~A   larg. ~A   alt. ~A~&"
	  (nodo-etichetta n)
	  (nodo-pos-h1 n)
	  (nodo-pos-v1 n)
	  (nodo-pos-h2 n)
	  (nodo-pos-h2 n)
	  (nodo-pos-radice-v1 n)
	  (nodo-pos-radice-coll n)
	  (nodo-pos-radice-v2 n)
	  (nodo-larghezza n)
	  (nodo-altezza n)
	  ))
|#

;;================================================================

(defparameter *cursor-ready* "plus")
(defparameter *cursor-grasp* "fleur")
(defparameter *cursor-busy*  "watch")

(defvar *cursor* *cursor-ready*)

(defmacro with-cursor ((cursor window) &body body)
  `(multiple-value-prog1
    (let ((*cursor* ,cursor))
      (set-window-cursor ,window ,cursor)
      ,@body)
    (set-window-cursor ,window *cursor*)))

(defun update-cursor (ww)
  (set-window-cursor ww *cursor*))

(defun cursor-ready (ww)
  (setf *cursor* *cursor-ready*)
  (update-cursor ww))

(defun cursor-grasp (ww)
  (setf *cursor* *cursor-grasp*)
  (update-cursor ww))

(defun cursor-busy (ww)
  (setf *cursor* *cursor-busy*)
  (update-cursor ww))

;;================================================================

;;; Do the rectangles r1 and r2 intersect?
(defun intersectp (r1h1 r1v1 r1h2 r1v2 r2h1 r2v1 r2h2 r2v2)
  (labels ((sta-dentro (h v h1 v1 h2 v2)
	     (and (<= h1 h h2)
		  (<= v1 v v2)))
	   (inters-linea-or (lh1 lv lh2  rh1 rv1 rh2 rv2)
	     (and (<= rv1 lv rv2)
		  (or (<= lh1 rh1 lh2)
		      (<= lh1 rh2 lh2))))
	   (inters-linea-ve (lh lv1 lv2   rh1 rv1 rh2 rv2)
	     (and (<= rh1 lh rh2)
		  (or (<= lv1 rv1 lv2)
		      (<= lv1 rv2 lv2)))))
    
    (or (sta-dentro r1h1 r1v1 r2h1 r2v1 r2h2 r2v2)
	(sta-dentro r2h1 r2v1 r1h1 r1v1 r1h2 r1v2)
	(inters-linea-or r2h1 r2v1 r2h2  r1h1 r1v1 r1h2 r1v2)
	(inters-linea-or r2h1 r2v2 r2h2  r1h1 r1v1 r1h2 r1v2)
	(inters-linea-ve r2h1 r2v1 r2v2  r1h1 r1v1 r1h2 r1v2)
	(inters-linea-ve r2h2 r2v1 r2v2  r1h1 r1v1 r1h2 r1v2)
	)))

(defconstant dislivello-minimo 4)
(defparameter *raggio* 12)

(defmethod join ((style (eql :Segments)) from-h from-v to-h to-v)
    (draw-line from-h from-v to-h to-v))

(defmethod join ((style (eql :Bus)) from-h from-v to-h to-v)
  (decf to-h 2)
  (let ((h/2 (round (+ from-h to-h) 2)))
    (draw-line from-h from-v h/2 from-v)
    (draw-line h/2 from-v h/2 to-v)
    (draw-line h/2 to-v to-h to-v)
    (draw-arrow to-h to-v)))

(defun draw-arrow (h v)
  (draw-line h v (- h 5) (- v 3))
  (draw-line h v (- h 5) (+ v 3))
  (draw-line (- h 2) v (- h 5) (- v 3))
  (draw-line (- h 2) v (- h 5) (+ v 3)))

(defmethod join ((style (eql :Round-Bus)) from-h from-v to-h to-v)
  (decf to-h 2)
  (let ((h/2 (truncate (+ from-h to-h) 2)))
    (if (<= (abs (- from-v to-v)) 1)
	(progn
	  (draw-line from-h from-v to-h to-v)
	  (draw-arrow to-h to-v))
	(progn
	  (if (< (abs (- from-v to-v)) (* 2 *raggio*))
	      (let ((*raggio* (floor (abs (- from-v to-v)) 2)))
		(join :Round-Bus from-h from-v (+ to-h 2) to-v))
	      (progn
		(draw-line from-h from-v (- h/2 *raggio*) from-v)
		(if (< from-v to-v)
		    (progn
		      (draw-arc (- h/2 *raggio*) (+ from-v *raggio*)
				*raggio* *raggio* 0 90)
		      (draw-line h/2 (+ from-v *raggio*) h/2 (- to-v *raggio*))
		      (draw-arc (+ h/2 *raggio*) (- to-v *raggio*) *raggio* *raggio* 180 90))
		    (progn
		      (draw-arc (- h/2 *raggio*) (- from-v *raggio*)
				*raggio* *raggio* 270 90)
		      (draw-line h/2 (- from-v *raggio*) h/2 (+ to-v *raggio*))
		      (draw-arc (+ h/2 *raggio*) (+ to-v *raggio*) *raggio* *raggio* 90 90)))
		(draw-line (+ h/2 *raggio*) to-v to-h to-v)
		(draw-arrow to-h to-v)
		))))
    ))

(defmethod join ((style (eql :Barrel-arcs)) from-h from-v to-h to-v)
    (cond ((<= (abs (- from-v to-v)) dislivello-minimo)
	   (draw-line from-h from-v to-h to-v))
	  ((< to-v from-v)
	   (draw-arc to-h from-v
		     (- to-h from-h) (- from-v to-v)
		     90 90))
	  (t;;(> to-v from-v)
	   (draw-arc to-h from-v
		     (- to-h from-h) (- to-v from-v)
		     180 90))
	  ))

(defmethod join ((style (eql :Cushion-arcs)) from-h from-v to-h to-v)
    (cond ((<= (abs (- from-v to-v)) dislivello-minimo)
	   (draw-line from-h from-v to-h to-v))
	  ((< to-v from-v)
	   (draw-arc from-h to-v
		     (- to-h from-h) (- from-v to-v)
		     270 90))
	  (t ;;(> to-v from-v)
	   (draw-arc from-h to-v
		     (- to-h from-h) (- to-v from-v)
		     0 90))
	  ))

(defmethod join ((style (eql :Mixed-arcs)) from-h from-v to-h to-v)
    (let ((h/2 (round (+ from-h to-h) 2))
	  (v/2 (round (+ from-v to-v) 2)))
      (cond ((<= (abs (- from-v to-v)) dislivello-minimo)
	     (draw-line from-h from-v to-h to-v))
	    ((< to-v from-v)
	     (draw-arc from-h v/2
		       (- h/2 from-h) (- from-v v/2)
		       270 90)
	     (draw-arc to-h v/2
		       (- to-h h/2) (- v/2 to-v)
		       90 90))
	    (t ;;(> to-v from-v)
	     (draw-arc from-h v/2
		       (- h/2 from-h) (- v/2 from-v)
		       0 90)
	     (draw-arc to-h v/2
		       (- to-h h/2) (- to-v v/2)
		       180 90))
	    )))


(defun make-painter (get-tree &key
			      (get-style (constantly :Bus))
			      (get-shadow-depth (constantly 2))
			      )
  (lambda (ww h1 v1 h2 v2)
    ;;(format t "~&h1 = ~A  v1 = ~A    h2 = ~A  V2 = ~A~%" h1 v1 h2 v2)
    (with-cursor (*cursor-busy* ww)
      ;;(incf h2 h1)
      ;;(incf v2 v1)
      (let ((style        (funcall get-style))
	    (shadow-depth (funcall get-shadow-depth))
	    (tree         (funcall get-tree))
	    )
	(set-window-document-size ww
				  (nodo-larghezza tree)
				  (nodo-altezza tree))
	(labels ((tree-join (p1 p2)
		   (let ((from-h (nodo-pos-h2 p1))
			 (from-v (nodo-pos-radice-coll p1))
			 (to-h (nodo-pos-h1 p2))
			 (to-v (nodo-pos-radice-coll p2)))
		     (join style from-h from-v to-h to-v)))
		 (painter (tree parent)
		   ;;(scrivi-nodo tree)
		   (let ((pos-h1  (nodo-pos-h1 tree))
			 (pos-h2  (nodo-pos-h2 tree))
			 (pos-v1  (nodo-pos-v1 tree))
			 ;;(pos-v2  (nodo-pos-v2 tree))
			 (pos-rv1 (nodo-pos-radice-v1 tree))
			 (pos-rv2 (nodo-pos-radice-v2 tree))
			 )
		     (when (intersectp h1 v1 h2 v2
					pos-h1
					pos-v1
					(+ pos-h1 (nodo-larghezza tree))
					(+ pos-v1 (nodo-altezza tree)))
		       (draw-box pos-h1 pos-rv1 pos-h2 pos-rv2)
		       
		       ;; Draws the shadow
		       (dotimes (i shadow-depth)
			 (let ((i1 (+ i 1)))
			   (draw-line (+ i1 pos-h1) (+ i pos-rv2) (+ i pos-h2) (+ i pos-rv2))
			   (draw-line (+ i pos-h2) (+ i pos-rv2) (+ i pos-h2) (+ i1 pos-rv1))
			   ))
		       
		       (draw-text (+ 3 pos-h1) (+ 1 pos-rv1) (nodo-etichetta tree))
		       
		       (loop for f in (nodo-figli tree) do (painter f tree))
		       )
		     (when parent
		       (tree-join parent tree))))
		 )
	  (painter tree nil)))
      )))

(defun get-integer (Mes Def)
  (let ((sdef (princ-to-string Def))
	ans)
    (loop
     until (setf ans (parse-integer (or (user-ask Mes sdef) sdef)
				    :junk-allowed t)))
    ans))

;;(defun get-integer (Mes Def)
;;  (let ((sdef (princ-to-string Def)))
;;    (or (parse-integer (or (user-ask Mes sdef)
;;			   sdef)
;;		       :junk-allowed t)
;;	Def)))

(defvar *default-style*             :Bus)
(defvar *default-font*              "fixed")
(defvar *default-horizontal-space*  80)
(defvar *default-vertical-space*    8)
(defvar *default-shadow-depth*      2)
(defvar *default-window-hsize*      600)
(defvar *default-window-vsize*      400)
(defvar *default-title*             "Pierpaolo's super tree viewer.")
(defvar *default-window-pos*        :Top)
(defvar *default-handle-events*     t)

(defvar *small-copy-horizontal-reduction* 4)
(defvar *small-copy-vertical-reduction*   4)
(defvar *small-copy-hsize-reduction*      4)
(defvar *small-copy-vsize-reduction*      4)
(defvar *small-copy-shadow-reduction*     4)
(defvar *small-copy-font*                 "-*-*-*-*-*-*-2-*-*-*-*-*-*-*")

(defconstant Styles
  '(:Segments :Bus :Round-Bus :Barrel-Arcs :Cushion-Arcs :Mixed-Arcs))

(defconstant window-positions
  '(:Top :Center :Bottom :Root :XY))

(defstruct window-info
  mouse-move
  mouse-down
  update-menu
  finalizer
  )

(defvar *window-table* (make-hash-table :test #'eq
					:size 10
					))

;;; ================================================================

(defmacro with-pipe-input-stream ((stream comando) &body body)
  `(let ((,stream (lisp:make-pipe-input-stream ,comando)))
    (unwind-protect
	 (progn ,@body)
      (close ,stream)))
  )

(defmacro with-pipe-output-stream ((stream comando) &body body)
  `(let ((,stream (lisp:make-pipe-output-stream ,comando)))
    (unwind-protect
	 (progn ,@body)
      (close ,stream)))
  )

;;; ================================================================

(defvar *show-message-default-title*  "Message")
(defvar *show-message-default-bg*     "linen")
(defvar *show-message-default-fg*     "black")

(defun show-message (message &key
			     (title *show-message-default-title*)
			     (bg    *show-message-default-bg*)
			     (fg    *show-message-default-fg*)
			     )
  
  (with-pipe-output-stream (dove (format nil "xmessage -bg ~W -fg ~W -name ~W -file -"
					 bg fg title))
    (princ message dove)))

;;; ================================================================


(defun show-or-print-info (sop tree-misurato title)
  (let ((message (format nil "~&Number of leaves: ~A~@
                                Number of internal nodes: ~A~@
                                Depth: ~A~@
                             "
			 (nodo-num-leaves tree-misurato)
			 (nodo-num-internal-nodes tree-misurato)
			 (nodo-rev-depth tree-misurato)
			 )))
    (ecase sop
      (:Print
       (princ message))
      (:Show
       (show-message message
		     :title (concatenate 'string title " - Info")))
      )
    ))


(defun show-tree (is-leaf-p branches label
		  tree &key
		       (handle-events *default-handle-events*)
		       (style      *default-style*)
		       (title      *default-title*)
		       (font       *default-font*)
		       (horizontal *default-horizontal-space*)
		       (vertical   *default-vertical-space*)
		       (hsize      *default-window-hsize*)
		       (vsize      *default-window-vsize*)
		       ((:shadow shadow-depth) *default-shadow-depth*)
		       (window-pos *default-window-pos*)
		       )

  (assert (member style Styles)
	  (style)
	  "Style must be one of ~W" Styles)
  
  (assert (or (member window-pos window-positions)
	      (listp window-pos))
	  (window-pos)
	  "Window-Pos must be one of ~W" window-positions)
  
  (cond ((null shadow-depth)		; To remain as compatible as possible
	 (setf shadow-depth 0))		;  with previously released versions.
	((integerp shadow-depth))
	(t
	 (setf shadow-depth *default-shadow-depth*)))
  
  (set-scrollbar-p t t)
  ;;(set-text-font "-*-courier-medium-r-*-*-14-20-*-*-*-*-*-*" 0 20)
  ;;(set-text-font "script14" 0 20)
  (set-text-font font 0 20)
  (set-default-window-size hsize vsize)
  (let* ((tree-misurato (misura is-leaf-p branches label
				tree nil 0 0 Horizontal Vertical font))
	 (ff (wopen title
		    (make-painter (lambda () tree-misurato)
				  :get-style (lambda () style)
				  :get-shadow-depth (lambda () shadow-depth)
				  )))
	 (menu-Style (menu-create "LineStyle"))
	 (menu-Segments     (menu-add-item  menu-Style "Segments"     #\S))
	 (menu-Bus          (menu-add-item  menu-Style "Bus"          #\U))
	 (menu-Round-Bus    (menu-add-item  menu-Style "Round Bus"    #\R))
	 (menu-Barrel-Arcs  (menu-add-item  menu-Style "Barrel Arcs"  #\B))
	 (menu-Cushion-Arcs (menu-add-item  menu-Style "Cushion Arcs" #\C))
	 (menu-Mixed-Arcs   (menu-add-item  menu-Style "Mixed Arcs"   #\M))
	 
	 (menu-Shadow (menu-create "Shadow"))
	 (menu-Shadow-Depth (menu-add-item  menu-Shadow
					    (format nil "Shadow depth ~2D" shadow-depth)
					    #\D))
	 
	 (menu-Spaces (menu-create "Spaces"))
	 (menu-Horizontal (menu-add-item  menu-Spaces
					  (format nil "Horizontal ~3D" Horizontal)
					  #\H))
	 (menu-Vertical (menu-add-item  menu-Spaces
					(format nil   "Vertical   ~3D" Vertical)
					#\V))
	 
	 (menu-Misc  (menu-create "Misc"))
	 (menu-Show-Info  (menu-add-item menu-Misc "Show Info"  #\H))
	 (menu-Print-Info (menu-add-item menu-Misc "Print Info" #\I))
	 (menu-Copy       (menu-add-item menu-Misc "Copy"  #\Y))
	 (menu-Small-Copy (menu-add-item menu-Misc "Small Copy"  #\A))
	 
	 (key/number-alist
	  `((:Segments     ,menu-Segments)
	    (:Bus          ,menu-Bus)
	    (:Round-Bus    ,menu-Round-Bus)
	    (:Barrel-Arcs  ,menu-Barrel-Arcs)
	    (:Cushion-Arcs ,menu-Cushion-Arcs)
	    (:Mixed-Arcs   ,menu-Mixed-Arcs)
	    ))
	 
	 ;; The status of the mouse
	 (mh 0)
	 (mv 0)
	 (woh0 0)
	 (wov0 0)
	 )
    ;;(declare (ignore menu-shadow-off))
    
    (if (and (listp window-pos)
	     (eq (first window-pos) :XY))
	(set-window-origin ff
			   (second window-pos)
			   (third window-pos))
	(set-window-origin ff 0 
			   (ecase window-pos
			     (:Top    0)
			     (:Bottom (- (nodo-altezza tree-misurato) vsize))
			     (:Root   (- (nodo-pos-radice-coll tree-misurato)
					 (truncate vsize 2)))
			     (:Center (truncate (nodo-altezza tree-misurato) 2))
			     )))
    
    (labels ((remove-all-checkmarks (menu)
	       (loop for i from 0 below (menu-size menu) do
		     (set-menu-item-checkmark menu i nil)))
	     
	     (update-menu (menu item)
	       (cond ((= menu menu-Style)
		      (remove-all-checkmarks menu)
		      (cond ((= item menu-Segments)
			     (setf style :Segments))
			    ((= item menu-Bus)
			     (setf style :Bus))
			    ((= item menu-Round-Bus)
			     (setf style :Round-Bus))
			    ((= item menu-Barrel-Arcs)
			     (setf style :Barrel-arcs))
			    ((= item menu-Cushion-Arcs)
			     (setf style :Cushion-arcs))
			    ((= item menu-Mixed-Arcs)
			     (setf style :Mixed-arcs)))
		      (set-menu-item-checkmark menu item t))
		     
		     ((= menu menu-Shadow)
		      (setf shadow-depth (get-integer "Shadow depth" shadow-depth))
		      (set-menu-item-label menu-Shadow
					   menu-shadow-depth
					   (format nil "Shadow-depth ~2D" shadow-depth)))
		     ((= menu menu-Spaces)
		      (cond ((= item menu-Horizontal)
			     (setf Horizontal (get-integer "Horizontal Space" Horizontal))
			     (set-menu-item-label menu-Spaces
						  menu-Horizontal
						  (format nil "Horizontal ~3D" Horizontal)))
			    ((= item menu-vertical)
			     (setf Vertical (get-integer "Vertical Space" Vertical))
			     (set-menu-item-label menu-Spaces
						  menu-Vertical
						  (format nil "Vertical   ~3D" Vertical)))
			    )
		      (setf tree-misurato
			    (misura is-leaf-p branches label
				    tree nil 0 0 Horizontal Vertical font))
		      )
		     ((= menu menu-Misc)
		      (cond ((= item menu-Show-Info)
			     (show-or-print-info :Show tree-misurato title))
			    ((= item menu-Print-Info)
			     (show-or-print-info :Print tree-misurato title))
			    ((= item menu-Copy)
			     (multiple-value-bind (hs vs) (window-size ff)
			       (show-tree is-leaf-p branches label tree
					  :handle-events handle-events
					  :style        style
					  :title        title
					  :font         font
					  :horizontal   horizontal
					  :vertical     vertical
					  :hsize        hs
					  :vsize        vs
					  :shadow       shadow-depth
					  :window-pos   (multiple-value-bind (h v) (window-origin ff)
							  `(:XY  ,h ,v))
					  )))
			    
			    ((= item menu-Small-Copy)
			     (multiple-value-bind (hs vs) (window-size ff)
			       (show-tree is-leaf-p branches label tree
					  :handle-events handle-events
					  :style        style
					  :title        (concatenate 'string title " - Small")
					  :font         *small-copy-font*
					  :horizontal   (ceiling horizontal   *small-copy-horizontal-reduction*)
					  :vertical     (ceiling vertical     *small-copy-vertical-reduction*)
					  :hsize        (ceiling hs           *small-copy-hsize-reduction*)
					  :vsize        (ceiling vs           *small-copy-vsize-reduction*)
					  :shadow       (ceiling shadow-depth *small-copy-shadow-reduction*)
					  :window-pos   (if (keywordp window-pos)
							    window-pos
							    :Top)
					  )))
			    ))
		     )
	       
	       ;; Prima o poi questo lo devo sistemare. XXXX
	       (window-change ff 0 0 32767 32767)
	       )
	     
	     (key->menu-number (key)
	       (cadr (assoc key key/number-alist :test 'eq)))
	     
	     (mouse-move (p1 p2)
	       (let ((delta-h (- p1 mh))
		     (delta-v (- p2 mv)))
		 (decf woh0 delta-h)
		 (decf wov0 delta-v)
		 (set-window-origin ff woh0 wov0)
		 (setf mh (- p1 delta-h))
		 (setf mv (- p2 delta-v))
		 ))
	     
	     (mouse-down (p1 p2)
	       (setf mh p1
		     mv p2)
	       (multiple-value-setq (woh0 wov0) (window-origin ff)))
	     )
      
      (menu-attach ff menu-Style)
      (menu-attach ff menu-Shadow)
      (menu-attach ff menu-Spaces)
      (menu-attach ff menu-Misc)
      
      (setf (gethash ff *window-table*)
	    (make-window-info :mouse-move #'mouse-move
			      :mouse-down #'mouse-down
			      :update-menu #'update-menu
			      :finalizer (lambda ()
					   (menu-delete menu-Style)
					   (menu-delete menu-Shadow)
					   (menu-delete menu-Spaces)
					   (menu-delete menu-Misc)
					   (wclose ff)
					   (remhash ff *window-table*)
					   )
			      ))
      
      (update-menu menu-Style (key->menu-number style))
      ;;(update-menu menu-Shadow (key->menu-number shadow))
      
      (handle-events :until-shutdown handle-events)
      )))

(defun handle-events (&key (until-shutdown nil))
  (loop
   (multiple-value-bind (evento finestra p1 p2)
       (if until-shutdown
	   (get-event)
	   (get-event-no-hang))
     (case evento
       (#.WE-NULL
	(return nil))
       (#.WE-MOUSE-MOVE
	(funcall (window-info-mouse-move (gethash finestra *window-table*))
		 p1 p2))
       (#.WE-MOUSE-DOWN
	(cursor-grasp finestra)
	(funcall (window-info-mouse-down (gethash finestra *window-table*))
		 p1 p2))
       (#.WE-MOUSE-UP
	(cursor-ready finestra))
       (#.WE-MENU
	(funcall (window-info-update-menu (gethash finestra *window-table*))
		 p1 p2))
       (#.WE-CLOSE
	(funcall (window-info-finalizer (gethash finestra *window-table*)))
	(when (zerop (hash-table-count *window-table*))
	  (return t))
       )))))
