(module top-level mzscheme
  (require (prefix mred: mred)
	   mzlib/class
	   mzlib/file
	   mzlib/pretty
	   mzlib/etc
	   mzlib/list
	   (prefix framework: framework)
	   "utils.ss"
	   "base.ss"
	   "panel.ss")
  
  ;; INVARIANT: If a snip is selected, then no ancestor or
  ;;  decendent of the snip can be selected. Otherwise, the
  ;;  dragging rules get complicated (perhaps impossible).
  
  ;; INVARIANT: a child must be ordered before its parent in the
  ;;  pasteboard. Not only does this affect drawing, but it also
  ;;  affects how select-all and rubber-banding work due to the
  ;;  ancestor/decendent-selection-exclusion rule.
  
  (define START-FRAME-WIDTH 100)
  (define START-FRAME-HEIGHT 100)

  ;; Keep in order of choice items:
  (define FRAME-MODE 0)
  (define DIALOG-MODE 1)
  (define PANEL-MODE 2)

  (define -FIRST-MODE- FRAME-MODE)
  (define -LAST-MODE- PANEL-MODE)

  (define top-font (send mred:the-font-list find-or-create-font 
			 12 'default 'normal 'normal #f))

  (define gb:edit%
    (class mred:pasteboard%
      (inherit set-selected find-next-selected-snip insert
	       find-first-snip is-selected? add-selected remove-selected
	       get-admin find-snip begin-edit-sequence end-edit-sequence
	       get-snip-location delete erase set-modified resize
	       invalidate-bitmap-cache
	       begin-write-header-footer-to-file end-write-header-footer-to-file
	       get-keymap)
      (private-field 
	[dragging? #f]
	[pasting? #f]
	[copying? #f]
	[cur-hilite #f]
	[cur-hilite-pos 0]
	[cur-id 1]
	[last-empty-click -inf.0])
      (public*
	[new-id (lambda () 
		  (begin0 
		    (number->string cur-id)
		    (set! cur-id (add1 cur-id))))]
	[for-each-snip
	 (lambda (f)
	   (let loop ([s (find-first-snip)])
	     (when s
	       (f s)
	       (loop (send s next)))))]
	[for-each-selected-snip
	 (lambda (f)
	   (let loop ([s (find-next-selected-snip #f)])
	     (when s
	       (f s)
	       (loop (find-next-selected-snip s)))))]
	[in-selected-hierarchy?
	 (lambda (s)
	   (or (is-selected? s)
	       (let ([parent (send s gb-get-parent)])
		 (and parent
		      (in-selected-hierarchy? parent)))))]
	[find-unselected-snip
	 (lambda (x y)
	   (let ([s (find-snip x y)])
	     (if (or (not s) (and (not (in-selected-hierarchy? s))
				  (send s container?)))
		 s
		 (let loop ([s (find-first-snip)])
		   (cond
		     [(not s) #f]
		     [(and (send s container?)
			   (not (in-selected-hierarchy? s)))
		      (let ([tb (box 0)]
			    [lb (box 0)]
			    [bb (box 0)]
			    [rb (box 0)])
			(get-snip-location s lb tb #f)
			(get-snip-location s rb bb #t)
			(if (and (<= (unbox lb) x (unbox rb))
				 (<= (unbox tb) y (unbox bb)))
			    s
			    (loop (send s next))))]
		     [else (loop (send s next))])))))]
	[find-snip-by-XXX
	 (lambda (id get)
	   (let/ec found
	     (for-each-snip
	      (lambda (s)
		(when (equal? id (get s))
		  (found s))))
	     #f))]
	[find-snip-by-id
	 (lambda (id)
	   (find-snip-by-XXX id (gb-id)))]
	[find-snip-by-original-id
	 (lambda (id)
	   (find-snip-by-XXX id gb-original-id))]
	[find-snip-by-name
	 (lambda (id)
	   (find-snip-by-XXX id gb-name))]

	[top-resized
	 (lambda (snip old-w old-h w h)
	   (when (eq? snip main-panel)
		 (unless (= top-level-type PANEL-MODE)
			 (invalidate-bitmap-cache 0 0
						  (+ (max old-w w) (* 2 margin))
						  (+ (max old-h h) (* 2 margin)
						     (or frame-label-h 0) 2)))))])

      (augment*
	[can-move-to?
	 (lambda (snip x y dragging?)
	   (or (not (eq? snip main-panel))
	       (and (= x main-panel-x)
		    (= y main-panel-y))))]
	[after-move-to
	 (lambda (snip x y dragging?)
	   (when dragging?
	     (send snip gb-drag-children-along x y)))]
	[after-resize
	 (lambda (snip w h did?)
	   (when (and (eq? snip main-panel) did?)
		 (unless (= top-level-type PANEL-MODE)
			 (invalidate-bitmap-cache 
			  0 0 last-frame-paint-w last-frame-paint-h))))]
	[on-interactive-move
	 (lambda (e)
	   (set! dragging? #t)
	   (for-each-snip (lambda (s) (send s gb-set-stable-position)))
	   (inner (void) on-interactive-move e))]
	[on-select
	 (lambda (s on?)
	   (when (and (not copying?) on?)
	     ; deselect parents:
	     (let loop ([p (send s gb-get-parent)])
	       (when p
		 (if (is-selected? p)
		     (remove-selected p)
		     (loop (send p gb-get-parent)))))
	     ; deselect children:
	     (for-each
	      (lambda (c)
		(when (is-selected? c)
		  (remove-selected c)))
	      (send s gb-get-children))))]
	[after-interactive-move
	 (lambda (e)
	   (set! dragging? #f)
	   
	   ;; Adjust parent of selected snips & move selected snip's children
	   (for-each-selected-snip
	    (lambda (snip)
	      (when (not (eq? snip main-panel))
		(let* ([parent (send snip gb-get-parent)]
		       [pos (if parent
				(send parent gb-get-child-pos snip)
				-1)])
		  (if cur-hilite
		      (when (or (not (eq? cur-hilite parent))
				(not (= pos cur-hilite-pos)))
			(when parent
			  (send parent gb-remove-child snip))
			(send cur-hilite gb-add-child snip cur-hilite-pos)
			(set! cur-hilite-pos (add1 cur-hilite-pos)))
		      (when parent
			(send parent gb-remove-child snip)
			(send snip gb-install this #f))))
		(send snip gb-need-recalc-size))))
	   
	   (when cur-hilite
	     (send cur-hilite gb-hilite #f)
	     (set! cur-hilite #f))

	   (inner (void) after-interactive-move e))])
      (override*
	[interactive-adjust-move
	 (lambda (snip x-box y-box)
	   (super interactive-adjust-move snip x-box y-box)
	   ;; The following doesn't really work very well.
	   #;
	   (let ([parent (send snip gb-get-parent)])
	     (when parent
	       (let-values ([(x y w h) 
			     (send (let loop ([p parent])
				     (let ([parent (send p gb-get-parent)])
				       (if parent
					   (loop parent)
					   p)))
				   gb-get-position-and-size)])
		 (when (and (<= x (unbox x-box) (+ x w))
			    (<= y (unbox y-box) (+ y h)))
		   (set-box! x-box (send snip gb-get-stable-x))
		   (set-box! y-box (send snip gb-get-stable-y)))))))]
	[interactive-adjust-resize
	 (lambda (snip wb hb)
	   (super interactive-adjust-resize snip wb hb)
	   (let-values ([(x-min y-min) (send snip gb-get-saved-min-size)])
	     (when (or (not (gb-x-stretch? snip))
		       (<= (unbox wb) x-min))
	       (set-box! wb x-min))
	     (when (or (not (gb-y-stretch? snip))
		       (<= (unbox hb) y-min))
	       (set-box! hb y-min))))])
      (augment*
	[after-interactive-resize
	 (lambda (snip)
	   (inner (void) after-interactive-resize snip)
	   (send snip gb-need-recalc-size))])
      (override*
	[on-default-event
	 (lambda (e)
	   (unless dragging?
	     (when (send e button-down?)
	       (unless (find-next-selected-snip #f)
		 (when ((- (send e get-time-stamp) last-empty-click) 
			. < . 
			(send (get-keymap) get-double-click-interval))
		   (open-dialog))
		 (set! last-empty-click (send e get-time-stamp)))))
	   (when dragging?
	     (let ([x (send e get-x)]
		   [y (send e get-y)]
		   [xb (box 0)]
		   [yb (box 0)])
	       (send (get-admin) get-dc xb yb)
	       (let ([lx (+ x (unbox xb))]
		     [ly (+ y (unbox yb))])
		 (let ([s (find-unselected-snip lx ly)])
		   (when s
		     (set! cur-hilite-pos (send s gb-find-position lx ly)))
		   (when (and (or cur-hilite s)
			      (not (eq? cur-hilite s)))
		     (begin-edit-sequence)
		     (when cur-hilite
		       (send cur-hilite gb-hilite #f)
		       (set! cur-hilite #f))
		     (when s
		       (set! cur-hilite s)
		       (send s gb-hilite #t))
		     (end-edit-sequence))))))
	   (super on-default-event e))]
	[on-double-click
	 (lambda (snip e)
	   (send snip gb-open-dialog))])
      (augment*
	[after-delete
	 (lambda (snip)
	   (for-each (lambda (i) (delete i)) (send snip gb-get-children))
	   (let ([parent (send snip gb-get-parent)])
	     (when parent
	       (send parent gb-remove-child snip)))
	   (inner (void) after-delete snip))]
	[can-insert?
	 (lambda (snip before x y)
	   (is-a? snip gb:snip%))]
	[after-insert
	 (lambda (snip behind x y)
	   (when pasting?
	     (dynamic-wind
	      (lambda () (set! pasting? #f))
	      (lambda () (send snip gb-install this #f))
	      (lambda () (set! pasting? #t))))
	   (inner (void) after-insert snip behind x y))])
      (private*
        [do-generic-paste
	 (lambda (time super-call)
	   (dynamic-wind
	       (lambda () (set! pasting? #t))
	       (lambda () (super-call time))
	       (lambda () (set! pasting? #f)))
	   (let ([a-paste #f])
	     (for-each-snip
	      (lambda (s)
		(unless a-paste
		  (let ([oi (gb-original-id s)])
		    (when oi
		      (set! a-paste s))))))
	     (handle-new-arrivals)
	     (when a-paste
	       (let ([top-paste (let loop ([a-paste a-paste])
				  (let ([p (send a-paste gb-get-parent)])
				    (if p
					(loop p)
					a-paste)))])
		 (send main-panel gb-add-child top-paste)
		 (set-selected top-paste)))))])
      (override*
        [do-paste
	 (lambda (time)
	   (do-generic-paste time (lambda (time) (super do-paste time))))]
	[do-paste-x-selection
	 (lambda (time)
	   (do-generic-paste time (lambda (time) (super do-paste-x-selection time))))])
      (public*
	[handle-new-arrivals
	 (lambda ()
	   (let loop ()
	     ((let/ec k
		(for-each-snip 
		 (lambda (s) 
		   (when (send s gb-reconnect-to-original-children)
		     (k loop))))
		void)))
	   (for-each-snip (lambda (s) (send s gb-forget-original-id))))])
      (override*
	[do-copy
	 (lambda (time delete?)
	   (dynamic-wind
	    (lambda () (set! copying? #t))
	    (lambda () 
	      (when (find-next-selected-snip #f)
		(letrec ([selected
			  (let loop ([s (find-next-selected-snip #f)])
			    (let ([next (find-next-selected-snip s)])
			      (if next
				  (cons s (loop next))
				  (list s))))]
			 [close-selected
			  (lambda (method)
			    (lambda (s)
			      (for-each
			       (lambda (child)
				 (method child)
				 ((close-selected method) child))
			       (send s gb-get-children))))])
		  (for-each (close-selected (lambda (x) (add-selected x))) selected)
		  (super do-copy time delete?)
		  (for-each (close-selected (lambda (x) (remove-selected x))) selected))))
	    (lambda () (set! copying? #f))))])
      (public*
	[get-selected-snip
	 (lambda () 
	   (let ([s (find-next-selected-snip #f)])
	     (if (or (not s)
		     (not (find-next-selected-snip s)))
		 main-panel
		 s)))]
	[insert-element
	 (lambda (c%)
	   (let* ([i (make-object c%)]
		  [se (get-selected-snip)]
		  [s (if (send se container?)
			 se
			 (or (gb-parent se)
			     main-panel))])
	     (send s gb-add-child i)
	     (set-selected s)))])
      (init-field
       [auto-show? #t]
       [top-level-type FRAME-MODE]
       [frame-label "Frame"]
       [top-name "top"])
      (private-field
       [frame-label-w #f]
       [frame-label-h #f]
       [last-frame-paint-w 0]
       [last-frame-paint-h 0]
       [main-panel-x 0]
       [main-panel-y 0]
       [margin 2]
       [configure-frame #f])
      (public*
        [get-top-level-type
	 (lambda () top-level-type)]
	[get-auto-show
	 (lambda () auto-show?)]
	[get-frame-label
	 (lambda () frame-label)]
        [open-dialog
	 (lambda ()
	   (unless configure-frame
	     (set! configure-frame (make-object 
				    (class mred:frame%
				       (augment*
					[on-close
					 (lambda ()
					   (set! configure-frame #f)
					   (inner (void) on-close))])
				       (super-new))
				    "Output"))
	     (let ([p (make-object mred:vertical-panel% configure-frame)])
	       (send p set-alignment 'left 'center)
	       (letrec ([update-frame
			 (lambda ()
			   (send main-panel gb-need-recalc-size)
			   (invalidate-bitmap-cache 0 0 'end 'end))]
			[kind-choice
			 (make-object mred:choice% 
				      "Output:" 
				      '("Frame" "Dialog" "Panel")
				      p
				      (lambda (c e)
					(let ([mode (send c get-selection)])
					  (set! top-level-type mode)
					  (send frame-stuff enable (< mode PANEL-MODE))
					  (update-frame))))]
			[frame-stuff (make-object mred:vertical-panel% p)]
			[name-text (make-one-line/callback-edit 
				    frame-stuff
				    "Scheme Name:"
				    (lambda (txt)
				      (set! top-name txt))
				    top-name)]
			[title-text (make-one-line/callback-edit 
				     frame-stuff
				     "Frame Title:"
				     (lambda (txt)
				       (unless (string=? frame-label txt)
					       (set! frame-label txt)
					       (let ([w frame-label-w]
						     [h frame-label-h])
						 (set! frame-label-h #f)
						 (update-frame))))
				     frame-label)]
			[auto-show-check (make-object mred:check-box%
						      "Show Automatically" frame-stuff
						      (lambda (c e)
							(set! auto-show? (send c get-value))))])
		 (send frame-stuff set-alignment 'left 'center)
		 (send frame-stuff enable (< top-level-type PANEL-MODE))
		 (send kind-choice stretchable-width #f)
		 (send kind-choice set-selection top-level-type)
		 (send auto-show-check set-value auto-show?))))
	   (send configure-frame show #t))]
        [get-main-location
	 (lambda (snip dc dx dy)
	   (when (eq? snip main-panel)
		 (if (= top-level-type PANEL-MODE)
		     (begin
		       (set! main-panel-x 0)
		       (set! main-panel-y 0))
		     (begin
		       (unless frame-label-h
			 (let-values ([(w h d a) (send dc get-text-extent
						       frame-label top-font)])
			   (set! frame-label-w w)
			   (set! frame-label-h h)))
		       (set! main-panel-x margin)
		       (set! main-panel-y (+ frame-label-h 2 margin))))
		 (set-box! dx main-panel-x)
		 (set-box! dy main-panel-y)))])
      (override*
	[on-paint
	 (lambda (pre? dc l t r b dx dy show-caret?)
	   (unless (or (not pre?) (= top-level-type PANEL-MODE)
		       (not main-panel))
	      (let ([tb (box 0)]
		    [lb (box 0)]
		    [bb (box 0)]
		    [rb (box 0)])
		(get-snip-location main-panel lb tb #f)
		(get-snip-location main-panel rb bb #t)
		(let* ([w (- (unbox rb) (unbox lb))]
		       [h (- (unbox bb) (unbox tb))]
		       [th (+ (or frame-label-h 0) 2)]
		       [tw (+ (* 2 margin) w)]
		       [totalh (+ th (* 2 margin) h)])
		  (when (and (or (<= 0 l tw) (<= 0 r tw) (<= l 0 tw r))
			     (or (<= 0 t totalh) (<= 0 b totalh) (<= t 0 totalh b)))
		    (set! last-frame-paint-w tw)
		    (set! last-frame-paint-h totalh)
		    (send dc draw-rectangle dx dy 
			  tw totalh)
		    (send dc draw-line dx (+ dy th)
			  (+ dx tw -1) (+ dy th))
		    (with-clipping-region 
		     dc (add1 dx) (add1 dy) 
		     (+ tw -2) (- th 2)
		     (lambda ()
		       (let ([f (send dc get-font)])
			 (send dc set-font f)
			 (send dc draw-text frame-label 
			       (+ dx (/ (- tw (or frame-label-w 0)) 2)) 
			       (+ dy 1))
			 (send dc set-font f)))))))))]
	[write-footers-to-file
	 (lambda (stream)
	   (super write-footers-to-file stream)
	   (let ([out (lambda (name val)
			(let ([info (box 0)])
			  (begin-write-header-footer-to-file stream name info)
			  (send stream put val)
			  (end-write-header-footer-to-file stream (unbox info))))])
	     (out "gb:mode" top-level-type)
	     (out "gb:title-utf8" (string->bytes/utf-8 frame-label))
	     (out "gb:top-name-utf8" (string->bytes/utf-8 top-name))
	     (out "gb:show" (if auto-show? 1 0))))]
	[read-footer-from-file
	 (lambda (stream kind)
	   (cond
	     [(string=? kind "gb:mode") 
	      (set! top-level-type 
		    (min -LAST-MODE- 
			 (max -FIRST-MODE- (send stream get-exact))))]
	     [(string=? kind "gb:title") 
	      (set! frame-label (bytes->string/latin-1 (send stream get-bytes)))]
	     [(string=? kind "gb:title-utf8") 
	      (set! frame-label (bytes->string/utf-8 (send stream get-bytes)))]
	     [(string=? kind "gb:top-name-utf8") 
	      (set! top-name (bytes->string/latin-1 (send stream get-bytes)))]
	     [(string=? kind "gb:top-name") 
	      (set! top-name (bytes->string/utf-8 (send stream get-bytes)))]
	     [(string=? kind "gb:show") 
	      (set! auto-show? (positive? (send stream get-exact)))]
	     [else (super read-footer-from-file stream kind)]))]
	[copy-self-to (lambda (e)
			(send e prepare-to-load)
			(super copy-self-to e)
			(send e done-loading #t))]
	[copy-self (lambda ()
		     (let ([e (new gb:edit%
				   [auto-show? auto-show?]
				   [top-level-type top-level-type]
				   [frame-label frame-label]
				   [top-name top-name])])
		       (copy-self-to e)
		       e))])
      (private-field
	[main-panel #f])
      (public*
	[get-main-panel (lambda () main-panel)]
	[create-main-panel
	 (lambda () 
	   (erase)
	   (set! main-panel (make-object gb:panel-snip%))
	   (insert main-panel 0 0)
	   (resize main-panel START-FRAME-WIDTH START-FRAME-HEIGHT)
	   (send main-panel gb-install this #f)
	   (send main-panel set-id "0")
	   (send main-panel gb-need-recalc-size)
	   (set-modified #f))])
      (public*
	[prepare-to-load
	 (lambda ()
	   (set! pasting? #t))]
	[done-loading
	 (lambda (ok?)
	   (set! pasting? #f)
	   (when ok?
	     (set! main-panel (find-snip-by-original-id "0"))
	     (send main-panel set-id "0")
	     (handle-new-arrivals)
	     (set-modified #f)))])
      (augment*
       [on-load-file
	(lambda (file mode)
	  (prepare-to-load))]
       [after-load-file
	(lambda (ok?)
	  (done-loading ok?))])

      ;; Code generation:
      (public*
	[instantiate
	 (lambda ()
	   (let ([code (build-code #t #f)])
	     (thread
	      (lambda ()
		(parameterize ([mred:current-eventspace (mred:make-eventspace)])
		   (eval code))))))]
	[view-source
	 (lambda ()
	   (let ([port (open-output-string)])
	     (pretty-print (build-code #f #f) port)
	     (let ([f (make-object (framework:frame:text-mixin framework:frame:editor%)
				   "code.scm")])
	       (send (send f get-editor) insert (get-output-string port))
	       (send f show #t))))]
	[build-code
	 (lambda (force-frame? as-class?)
	   (let* ([main (get-main-panel)]
		  [type (get-top-level-type)]
		  [frame-label (if (and (= type PANEL-MODE) force-frame?)
				   "Panel Tester"
				   (get-frame-label))]
		  [mode (make-output-mode as-class? force-frame?)]
		  [top (string->symbol top-name)])
	     `(,@(cond
		  [as-class? '(class object%)]
		  [(and (= type PANEL-MODE)
			(not force-frame?))
		   '(lambda (top))]
		  [else '(begin)])
		,@(if as-class?
		      (if (and (= type PANEL-MODE) (not force-frame?))
			  '((init top))
			  '())
		      '())
		,@(cond
		   [(or (= type FRAME-MODE) 
			(and (= type PANEL-MODE) force-frame?))
		    (if as-class?
			`((public* [get-top% (lambda () frame%)])
			  (field [,top (make-object (get-top%) ,frame-label)]))
			`((define ,top (make-object frame% ,frame-label))))]
		   [(= type PANEL-MODE) null]
		   [else
		    (if as-class?
			`((public* [get-top% (lambda () dialog%)])
			  (field [,top (make-object (get-top%) ,frame-label)]))
			`((define ,top (make-object dialog% ,frame-label))))])
		,@(send main gb-instantiate 'top mode)
		,@(if as-class?
		      '((super-new))
		      null)
		,@(if (and (not force-frame?)
			   (or (= type PANEL-MODE) (not (get-auto-show))))
		      null
		      `((send ,top show #t))))))])

      (super-new)))

  (provide gb:edit%))