;;   gui.scm - MrEd GUI for NanoCAD
;;   Copyright (C) 1996,1997 Will Ware
;;   
;;   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 should have received a copy of the GNU General Public License
;;   along with this program; if not, write to the Free Software
;;   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;;   I can be reached via email at .

;; ******************************************************************
;; Conversion, screen coordinates <=> angstroms

(define scale-factor 25.0)

(define (set-scale-factor x) (set! scale-factor x))
(define (su2a x) (/ x scale-factor))
(define (a2su x) (* x scale-factor))

(define (select-atom x y)
  (set! x (su2a x))
  (set! y (su2a y))
  (do ((n #f)
       (i 0 (+ i 1))
       (p 0.0)
       (sq-dist 0.0)
       (min-sq-dist 0.0)
       (L atom-list (cdr L)))
      ((null? L) n)
    (set! p (- x (vector-ref ((car L) 'position) 0)))
    (set! sq-dist (* p p))
    (set! p (- y (vector-ref ((car L) 'position) 1)))
    (set! sq-dist (+ sq-dist (* p p)))
    (if (or (not n) (< sq-dist min-sq-dist))
	(let ()
	  (set! min-sq-dist sq-dist)
	  (set! n i)))))

(define (move-atom n x y)
  (let ((a (list-ref atom-list n)))
    (a 'set-pos
       (vector (su2a x)
	       (su2a y)
	       (vector-ref (a 'position) 2)))))

;; ******************************************************************
;; Drawing lists

(define (make-draw-object type x1 y1 x2 y2 z xf yf pen element)
  (lambda (x)
    (case x
      ('type type)
      ('x1 x1)
      ('y1 y1)
      ('x2 x2)
      ('y2 y2)
      ('z z)
      ('xf xf)
      ('yf yf)
      ('pen pen) ('element element))))

(define (bubble-1 criterion lst)
  (cond ((not (pair? lst)) lst)
	((null? (cdr lst)) lst)
	(else (let ((a (car lst))
		    (b (cadr lst)))
		(if (apply criterion (list a b))
		    (cons b (bubble-1 criterion (cons a (cddr lst))))
		    (cons a (bubble-1 criterion (cdr lst))))))))

(define (bubble-sort criterion lst)
  (cond ((null? lst) '())
	(else (set! lst (reverse (bubble-1 criterion (reverse lst))))
	      (cons (car lst)
		    (bubble-sort criterion (cdr lst))))))

;; If MrEd defines a sorter, use that, otherwise use bubblesort.

(cond ((defined? 'quicksort) (define (sorter crit lst) (quicksort lst crit)))
      ;; ((defined? 'qsort) (define (sorter crit lst) (qsort lst crit)))
      ;; ((defined? 'sort) (define (sorter crit lst) (sort crit lst)))
      (else (define (sorter crit lst) (bubble-sort crit lst))))

;; For wireframe drawing lists, we want only to return an unordered list
;; of bonds, and we can throw away information about bond order. This
;; should be very quick, so we can draw wireframes while rotating a
;; molecule smoothly.

(define (wireframe-drawing-list)
  (entering "wireframe-drawing-list")
  (let ((DL '()))
    (dolist
     (bond bond-list)
     (let ((pos1 ((list-ref atom-list (bond 'first)) 'position))
	   (pos2 ((list-ref atom-list (bond 'second)) 'position)))
       (set! DL
	     (cons
	      (make-draw-object
	       'bond
	       (a2su (vector-ref pos1 0))
	       (a2su (vector-ref pos1 1))
	       (a2su (vector-ref pos2 0))
	       (a2su (vector-ref pos2 1))
	       #f #f #f 'normal #f)
	      DL))))
    DL))

;; To create detailed drawing lists, we want to specify an order in which
;; things are drawn, with the most-positive-z-value things drawn first, and
;; the more-negative-z-value things drawn on top of them (the Painter's
;; algorithm) for crude depth rendering. To do this we use a data structure,
;; a list of lists, each inner list containing a boolean, an integer, and a
;; z-value. The boolean tells whether this object is in the atom list or the
;; bond list, the integer indexes into that list, and the z value represents
;; either an atomic nucleus or the midpoint of a bond.

(define (detailed-drawing-list)
  (entering "detailed-drawing-list")
  ;; the first thing we'll be doing is sorting the drawing list by Z
  ;; coordinates, so compute them for bonds first, then for atoms
  (let ((DL '()))
    (dbgprintf "detailed-drawing-list: bonds~%")
    (dolist
     (bond bond-list)
     (let ((pos1 ((list-ref atom-list (bond 'first)) 'position))
	   (pos2 ((list-ref atom-list (bond 'second)) 'position)))
       (set! DL
	     (cons
	      (make-draw-object
	       'bond
	       (a2su (vector-ref pos1 0))
	       (a2su (vector-ref pos1 1))
	       (a2su (vector-ref pos2 0))
	       (a2su (vector-ref pos2 1))
	       (* 0.5 (+ (vector-ref pos1 2) (vector-ref pos2 2)))
	       #f #f
	       (case (bond 'order)
		 (2 'double-bond)
		 (3 'triple-bond)
		 (else 'normal))
	       #f)
	      DL))))
    (dbgprintf "detailed-drawing-list: atoms~%")
    (dolist (atom atom-list)
	    (let ((atm-pos (atom 'position))
		  (atm-force (atom 'force)))
	      (set! DL
		    (cons
		     (make-draw-object
		      'atom
		      (a2su (vector-ref atm-pos 0))
		      (a2su (vector-ref atm-pos 1))
		      #f
		      #f
		      (vector-ref atm-pos 2)
		      (* 0.05 (a2su (vector-ref atm-force 0)))
		      (* 0.05 (a2su (vector-ref atm-force 1)))
		      'normal
		      (atom 'element))
		     DL))))
    (dbgprintf "detailed-drawing-list: sorting~%")
    (sorter (lambda (x y) (< (x 'z) (y 'z))) DL)))

;; ******************************************************************

(define center-x #f)
(define center-y #f)
(define start-mouse ())
(define selected-atom 0)
(define current-element "C")
(define bond-order 1)
(define atom-drawing-radius 15)
(define draw-force-vectors #f)
(define current-mouse-button #f)

(define (select-an-atom x y)
  (set! selected-atom
	(select-atom (- x center-x)
		     (- y center-y))))

(define (rotate-press x y)
  (center-structure)
  (set! start-mouse (list x y)))

(define (rotate-drag x y)
  (rotate-structure
   (* 0.01 (- x (car start-mouse)))
   (* -0.01 (- y (cadr start-mouse))))
  (set! start-mouse (list x y))
  (update-display #f))

(define (rotate-release x y)
  (update-display #t))

(define (move-drag x y)
  (move-atom selected-atom
	     (- x center-x)
	     (- y center-y))
  (update-display #t))

(define (addatom-press x y)
  (let ((x1 (- x center-x))
	(y1 (- y center-y)))
    (add-atom current-element
	      (vector (su2a (- x center-x)) (su2a (- y center-y)) 0.0))
    (update-display #t)))

(define (deleteatom-press x y)
  (select-an-atom x y)
  (delete-atom selected-atom)
  (update-display #t))

(define (deletebond-release x y)
  (let ((n selected-atom))
    (select-an-atom x y)
    (delete-bond n selected-atom)
    (update-display #t)))

(define (addbond-release x y)
  (let ((n selected-atom))
    (select-an-atom x y)
    (if (not (= n selected-atom))
	(add-bond bond-order selected-atom n))
    (update-display #t)))

(define (do-nothing x y) ())

(define press-function rotate-press)
(define drag-function rotate-drag)
(define release-function rotate-release)

;; For now, pay attention only to the left mouse button

(define (press-function-b x y)
  (if (eq? current-mouse-button 1)
      (press-function x y)))

(define (drag-function-b x y)
  (if (eq? current-mouse-button 1)
      (drag-function x y)))

(define (release-function-b x y)
  (if (eq? current-mouse-button 1)
      (release-function x y)))


(define my-frame%
  (make-class wx:frame%
              (public
		   (on-size (lambda (w h) '()))
		   (change-resize-function
		     (lambda (f)
			 (set! on-size f))))))

(define my-canvas%
  (make-class wx:canvas%
	      (private
	       (which-button 0))
              (public
               (on-event
		(lambda (event)
		  (let ((which-button
			 (cond ((send event button? 1) 1)
			       ((send event button? 2) 2)
			       (else 3)))
			(x (send event get-x))
			(y (send event get-y)))
		    (cond ((send event button-down? -1)
			   (set! current-mouse-button which-button)
			   (press-function-b x y))
			  ((send event button-up? -1)
			   (release-function-b x y)
			   (set! current-mouse-button #f))
			  ((and current-mouse-button
				(send event dragging?))
			   (drag-function-b x y))
			  (else #f))))))))

(define (show-gui) (send this-session awaken))
(define (hide-gui) (send this-session snooze))
(define (force-rotate-mode) (send this-session force-rotate-mode))

;; annoying little hack, because the name of the command changed after
;; version 42
(if (equal? (version) "42")
    (define (get-cursor-hack panel u v)
      (send panel get-cursor u v))
    (define (get-cursor-hack panel u v)
      (send panel get-item-cursor u v)))

(define (update-display full-blown)
  (update-session full-blown
		  (ivar this-session canvas-width)
		  (ivar this-session canvas-height)
		  (ivar this-session canvas-dc)
		  (ivar this-session atom-color)
		  (ivar this-session select-pen)))

(define session%
  (class () ()
	 (public
	  (PANEL-WIDTH
	   (if (eq? (system-type) 'unix) 500 390))
	  (PANEL-HEIGHT
	   (if (eq? (system-type) 'unix) 200 230))
	  (CANVAS-WIDTH 400)
	  (CANVAS-HEIGHT 400)
	  (a-frame
	   (make-object my-frame%
			'() ; No parent frame
			"NanoCAD Control Panel"
			-1 -1 ; Use the default position
			PANEL-WIDTH PANEL-HEIGHT))
	  (b-frame
	   (make-object my-frame%
			'() ; No parent frame
			"NanoCAD Structure View"
			-1 -1 ; Use the default position
			CANVAS-WIDTH CANVAS-HEIGHT))
	  (canvas-height 10)
	  (canvas-width 10)
	  (canvas
	   (make-object my-canvas%
			b-frame
			0 0
			canvas-width canvas-height
			wx:const-retained ""))
	  (canvas-dc
	   (send canvas get-dc))
	  (awaken
	   (lambda ()
	     (send a-frame show #t)
	     (send b-frame show #t)))
	  (snooze
	   (lambda ()
	     (send canvas-dc end-drawing)
	     (send a-frame show #f)
	     (send b-frame show #f))))

	 (private
	  (internal-update
	   (lambda (full-blown)
	     (update-session full-blown
			     canvas-width
			     canvas-height
			     canvas-dc
			     atom-color
			     select-pen)))
	  (carbon-brush
	   (make-object wx:brush% "BLACK" wx:const-solid))
	  (hydrogen-brush
	   (make-object wx:brush% "WHITE" wx:const-solid))
	  (oxygen-brush
	   (make-object wx:brush% "RED" wx:const-solid))
	  (nitrogen-brush
	   (make-object wx:brush% "BLUE" wx:const-solid))

	  (normal-pen
	   (make-object wx:pen% "BLACK" 1 wx:const-solid))
	  (double-bond-pen
	   (make-object wx:pen% "BLACK" 3 wx:const-solid))
	  (triple-bond-pen
	   (make-object wx:pen% "BLACK" 5 wx:const-solid))
	  (force-vector-pen
	   (make-object wx:pen% "RED" 1 wx:const-solid))

	  (a-panel
	   (make-object wx:panel%
			a-frame
			0 0 PANEL-WIDTH PANEL-HEIGHT))
	  (load-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (load-structure (wx:file-selector ""))
			  (internal-update #t))
			"Load"))
	  (save-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (save-structure (wx:file-selector ""))
			  (internal-update #t))
			"Save"))
	  (save-xyz-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (save-structure-xyz (wx:file-selector ""))
			  (internal-update #t))
			"SaveXYZ"))
	  (clear-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (clear-structure)
			  (internal-update #t))
			"Clear"))
	  (emin-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (emin-step)
			  (internal-update #t))
			"Emin"))
	  (hide-button
	   (make-object wx:button%
			a-panel
			(lambda (self event)
			  (snooze))
			"HideGUI")))
	 (sequence
	   (send a-panel new-line))
	 (private
	  (show-forces-checkbox
	   (make-object wx:check-box%
			a-panel
			(lambda (self event)
			  (set! draw-force-vectors (send event checked?))
			  (internal-update #t))
			"Show Force Vectors"))
	  (use-torsion-checkbox
	   (make-object wx:check-box%
			a-panel
			(lambda (self event)
			  (set! use-torsion-forces (send event checked?)))
			"Use Torsion Forces"))
	  (use-vdw-checkbox
	   (make-object wx:check-box%
			a-panel
			(lambda (self event)
			  (set! use-vdw-forces (send event checked?)))
			"Use VDW Forces")))
	 (sequence
	   (send a-panel new-line))
	 (public
	  (select-pen
	   (lambda (n)
	     (case n
	       ('force-vector (send canvas-dc set-pen force-vector-pen))
	       ('double-bond  (send canvas-dc set-pen double-bond-pen))
	       ('triple-bond  (send canvas-dc set-pen triple-bond-pen))
	       (else          (send canvas-dc set-pen normal-pen)))))
	  (atom-color
	   (lambda (element-name)
	     (cond
	      ((equal? element-name "C")
	       (send canvas-dc set-brush carbon-brush))
	      ((equal? element-name "H")
	       (send canvas-dc set-brush hydrogen-brush))
	      ((equal? element-name "O")
	       (send canvas-dc set-brush oxygen-brush))
	      (else
	       (send canvas-dc set-brush nitrogen-brush))))))
	 (private
	  (mode-selector
	   (make-object wx:radio-box%
			a-panel
			(lambda (self event)
			  (let ((n (send event get-command-int)))
			    (case n
			      (0 (set! press-function rotate-press)
				 (set! drag-function rotate-drag)
				 (set! release-function rotate-release))
			      (1 (set! press-function select-an-atom)
				 (set! drag-function move-drag)
				 (set! release-function do-nothing))
			      (2 (set! press-function addatom-press)
				 (set! drag-function do-nothing)
				 (set! release-function do-nothing))
			      (3 (set! press-function deleteatom-press)
				 (set! drag-function do-nothing)
				 (set! release-function do-nothing))
			      (4 (set! press-function select-an-atom)
				 (set! drag-function do-nothing)
				 (set! release-function addbond-release))
			      (5 (set! press-function select-an-atom)
				 (set! drag-function do-nothing)
				 (set! release-function deletebond-release)))))
			""
			-1 -1 -1 -1
			(list "Rotate" "MoveAtom" "AddAtom" "DeleteAtom"
			      "AddBond" "DeleteBond")))
	  (bond-order-selector
	   (make-object wx:radio-box%
			a-panel
			(lambda (self event)
			  (let ((n (send event get-command-int)))
			    (set! bond-order (+ n 1))))
			"Bond"
			-1 -1 -1 -1
			(list "Single" "Double" "Triple")))
	  (element-selector
	   (make-object wx:radio-box%
			a-panel
			(lambda (self event)
			  (let ((n (send event get-command-int)))
			    (case n
			      (0 (set! current-element "C"))
			      (1 (set! current-element "H"))
			      (2 (set! current-element "O"))
			      (else (set! current-element "N")))))
			""
			-1 -1 -1 -1
			(list "Carbon" "Hydrogen" "Oxygen" "Nitrogen")))
	  (zoom-factor
	   (make-object wx:radio-box%
			a-panel
			(lambda (self event)
			  (let ((n (send event get-command-int)))
			    (case n
			      (0 (set-scale-factor 10.0))
			      (1 (set-scale-factor 25.0))
			      (2 (set-scale-factor 50.0))
			      (else (set-scale-factor 100.0))))
			  (set! atom-drawing-radius (* 0.6 scale-factor))
			  (internal-update #t))
			"Zoom"
			-1 -1 -1 -1
			(list "10" "25" "50" "100")))
	  (emin-convergence
	   (make-object wx:radio-box%
			a-panel
			(lambda (self event)
			  (let ((n (send event get-command-int)))
			    (case n
			      (0 (set! emin-factor fine-emin-factor))
			      (else (set! emin-factor coarse-emin-factor)))))
			"Emin"
			-1 -1 -1 -1
			(list "Fine" "Coarse"))))
	 (sequence
	   (send a-panel new-line)
	   (send a-panel fit))
	 (public
	  (force-rotate-mode
	   (lambda ()
	     (send mode-selector set-selection 0)
	     (set! press-function rotate-press)
	     (set! drag-function rotate-drag)
	     (set! release-function rotate-release))))
	 (private
	  (canvas-y
	   (let ((u (box 0)) (v (box 0)))
	     (get-cursor-hack a-panel u v)
	     (unbox v)))
	  (resize-canvas
	   (lambda (w h)
	     ;; (set! canvas-height (- h canvas-y))
	     (set! canvas-height h)
	     (set! canvas-width w)
	     (set! canvas
		   (make-object my-canvas%
				b-frame
				;; 0 canvas-y
				0 0
				canvas-width canvas-height
				wx:const-retained ""))
	     (send canvas-dc end-drawing)
	     (set! canvas-dc
		   (send canvas get-dc))
	     (send canvas-dc begin-drawing)
	     (internal-update #t))))
	 (sequence
	   (set! error-msg
		 (lambda (txt)
		   (send canvas-dc draw-text txt 10 10)))
	   (set! warning-msg
		 (lambda (txt)
		   (send canvas-dc draw-text txt 10 20)))
	   (set-scale-factor 25.0)
	   (send zoom-factor set-selection 1)
	   (send use-vdw-checkbox set-value #t)
	   (send b-frame change-resize-function resize-canvas)
	   (awaken)
	   (set! center-x (* 0.5 canvas-width))
	   (set! center-y (* 0.5 canvas-height))
	   (send canvas-dc begin-drawing))))

(define (update-session full-blown
			canvas-width
			canvas-height
			canvas-dc
			atom-color
			select-pen)
  (entering "update-session")
  (set! center-x (* 0.5 canvas-width))
  (set! center-y (* 0.5 canvas-height))
  (send canvas-dc clear)
  (if full-blown
      (let ((DL ())
	    (minus-half-radius (* -0.5 atom-drawing-radius)))
	(if draw-force-vectors (compute-forces))
	(set! DL (detailed-drawing-list))
	(map (lambda (z)
	       (if (eq? (z 'type) 'atom)
		   (let ()
		     (atom-color ((z 'element) 'name))
		     (send canvas-dc draw-ellipse
			   (+ (z 'x1) center-x minus-half-radius)
			   (+ (z 'y1) center-y minus-half-radius)
			   atom-drawing-radius atom-drawing-radius)
		     (if draw-force-vectors
			 (let ()
			   (select-pen 'force-vector)
			   (send canvas-dc draw-line
				 (+ center-x (z 'x1))
				 (+ center-y (z 'y1))
				 (+ center-x (z 'x1) (z 'xf))
				 (+ center-y (z 'y1) (z 'yf)))
			   (select-pen 'normal))))
		   (let ()
		     (select-pen (z 'pen))
		     (send canvas-dc draw-line
			   (+ center-x (z 'x1))
			   (+ center-y (z 'y1))
			   (+ center-x (z 'x2))
			   (+ center-y (z 'y2)))
		     (select-pen 'normal))))
	     DL))
      (map (lambda (z)
	     (send canvas-dc draw-line
		   (+ center-x (z 'x1))
		   (+ center-y (z 'y1))
		   (+ center-x (z 'x2))
		   (+ center-y (z 'y2))))
	   (wireframe-drawing-list))))