#|

todo:

pict snip :
- snipclass for running snips outside of drscheme
- need to toggle the picts back to scheme code when
  important things happen (save, execute, etc).
- should save the true pict size when it gets recorded.
- show the true size in the GUI
- when a snip is deleted from inside the pasteboard, remove it from the caches
- check that when a snip is inserted, things revert (?).
   maybe something better should happen?
- test up-to-date? flag
|#

(module tool mzscheme
  (require drscheme/tool
           mred
           mzlib/class
           mzlib/unit
           mzlib/contract
           string-constants
           framework
           texpict/mrpict
           texpict/pict-value-snip
           mzlib/list
           "private/pict-box-lib.ss"
           "private/image-snipr.ss")

  (provide tool@
           get-snp/poss
           build-lib-pict-stx)

  (define orig-inspector (current-code-inspector))
  (define orig-lcp (current-library-collection-paths))

  (define-syntax syntax/cert 
    (syntax-rules ()
      [(_ stx tmpl) (let ([stx stx])
		      (syntax-recertify
		       (syntax/loc stx tmpl)
		       stx
		       orig-inspector
		       #f))]))

  (define tool@
    (unit 
      (import drscheme:tool^)
      (export drscheme:tool-exports^)
      (define original-output-port (current-output-port))
      (define (oprintf . args) (apply fprintf original-output-port args))
      
      (define sc-hide-picts (string-constant slideshow-hide-picts))
      (define sc-show-picts (string-constant slideshow-show-picts))
      (define sc-cannot-show-picts (string-constant slideshow-cannot-show-picts))
      (define sc-insert-pict-box (string-constant slideshow-insert-pict-box))
      
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;; pict box
      ;;
      
      
      (define pict-pasteboard%
        (class pasteboard%
          (inherit get-admin)
          
          (define/augment (after-insert snip before x y)
            (let ([admin (get-admin)])
              (when (is-a? admin editor-snip-editor-admin<%>)
                (send (send admin get-snip) inserted-snip)))
            (inner (void) after-insert snip before x y))
          
          (super-new)))
      
      (define pict-snip%
        (class* decorated-editor-snip% (readable-snip<%>)
          (inherit get-editor)

          (define show-picts? #f)
          
          ;; only for use in the copy method and the read snipclass method
          (define/public (set-show-picts b) (set! show-picts? b))
          
          ;; up-to-date? : boolean
          ;; indicates if the recent shapes cache is up to date
          (define up-to-date? #f)
          
          ;; only for use in the copy method and the read snipclass method
          (define/public (set-up-to-date b) (set! up-to-date? b))
          
          ;; bitmap-table : hash-table[snip -o> bitmap]
          ;; maps from the true (Scheme) snip to its current bitmap
          (define bitmap-table (make-hash-table))
          
          ;; only for use in the copy method and the read snipclass method
          (define/public (set-bitmap-table bt) (set! bitmap-table bt))
          
          (define/override (make-editor) (make-object pict-pasteboard%))
          (define/override (get-corner-bitmap) slideshow-bm)
          
          (define/override (copy)
            (let* ([cp (make-object pict-snip%)]
                   [ed (send cp get-editor)])
              (send (get-editor) copy-self-to ed)
              (let ([bt (make-hash-table)])
                (hash-table-for-each bitmap-table (lambda (k v) (hash-table-put! bt (send k copy) v)))
                (send cp set-bitmap-table bt)
                (send cp set-show-picts show-picts?)
                (send cp set-up-to-date up-to-date?)
                cp)))
          
          
          (define/override (get-menu)
            (let ([menu (instantiate popup-menu% () (title #f))])
              (cond
                [show-picts?
                 (make-object checkable-menu-item%
                   sc-hide-picts
                   menu
                   (lambda (x y)
                     (hide-picts)))]
                [up-to-date?
                 (make-object checkable-menu-item%
                   sc-show-picts
                   menu
                   (lambda (x y)
                     (show-picts)))]
                [else
                 (let ([m (make-object menu-item%
                            sc-cannot-show-picts
                            menu
                            (lambda (x y) void))])
                   (send m enable #f))])
              menu))
          
          (define/public (update-bitmap-table sub-snips sub-bitmaps)
            (let ([hidden-table (make-hash-table)])
              (let loop ([snip (send (get-editor) find-first-snip)])
                (cond
                  [snip
                   (when (is-a? snip image-snip/r%)
                     (hash-table-put! hidden-table (send snip get-orig-snip) snip))
                   (loop (send snip next))]
                  [else (void)]))
              (for-each (lambda (snip bitmap) 
                          (hash-table-put! bitmap-table snip bitmap)
                          (let ([showing (hash-table-get hidden-table snip (lambda () #f))])
                            (when showing
                              (send showing set-bitmap bitmap))))
                        sub-snips
                        sub-bitmaps)
              (set! up-to-date? #t)))
          
          (define/private (show-picts)
            (let ([pb (get-editor)])
              (set! show-picts? #t)
              (send pb begin-edit-sequence)
              
              (set! system-insertion? #t)
              (hash-table-for-each 
               bitmap-table
               (lambda (snip bitmap)
                 (let ([bm-snip (make-object image-snip/r% bitmap snip)])
                   (let-values ([(x y) (snip-location pb snip)])
                     (send snip release-from-owner)
                     (send pb insert bm-snip x y)))))
              (set! system-insertion? #f)
              
              (send pb end-edit-sequence)))
          
          (define/private (hide-picts)
            (let ([pb (get-editor)])
              (set! show-picts? #f)
              
              (send pb begin-edit-sequence)
              
              (let ([all-snips (let loop ([snip (send pb find-first-snip)])
                                 (cond
                                   [snip (cons snip (loop (send snip next)))]
                                   [else null]))])
                (set! system-insertion? #t)
                (for-each (lambda (snip)
                            (when (is-a? snip image-snip/r%)
                              (let ([real-snip (send snip get-orig-snip)])
                                (let-values ([(x y) (snip-location pb snip)])
                                  (send snip release-from-owner)
                                  (send pb insert real-snip x y)))))
                          all-snips)
                (set! system-insertion? #f))
              
              (send pb end-edit-sequence)))
          
          ;; called on user thread
          (define/public (read-special file line col pos)
            (let ([ans-chan (make-channel)])
              (parameterize ([current-eventspace drs-eventspace])
                (queue-callback
                 (lambda ()
                   (channel-put ans-chan (get-snp/poss this)))))
              (let ([snp/poss (channel-get ans-chan)])
                (build-lib-pict-stx 
                 (lambda (ids)
                   (with-syntax ([(ids ...) ids]
                                 [this this]
                                 [build-bitmap/check build-bitmap/check]
                                 [drs-eventspace drs-eventspace]
                                 [(subsnips ...) (map snp/pos-snp snp/poss)]
                                 [(bitmap-ids ...) (generate-ids "drawer-id" (map snp/pos-snp snp/poss))])
                     (syntax
                      (let ([bitmap-ids (build-bitmap/check ids (pict-width ids) (pict-height ids) draw-pict pict?)] ...)
                        (parameterize ([current-eventspace drs-eventspace])
                          (queue-callback 
                           (lambda () ;; drs eventspace
                             (send this update-bitmap-table 
                                   (list subsnips ...)
                                   (list bitmap-ids ...)))))))))
                 snp/poss))))
          
          (define/override (write stream-out)
            (send stream-out put (if show-picts? 1 0))
            (send stream-out put (if up-to-date? 1 0))
            (send (get-editor) write-to-file stream-out))
          (define/override (make-snip) (new pict-snip%))
          
          (define system-insertion? #f)
          (define/public (inserted-snip)
            (unless system-insertion?
              (set! up-to-date? #f)
              (when show-picts?
                (hide-picts))))
          
          (inherit show-border set-snipclass)
          (super-new)
          (show-border #t)
          (set-snipclass lib-pict-snipclass)))
      
      (define lib-pict-snipclass%
        (class snip-class%
          (define/override (read stream-in)
            (let* ([snip (new pict-snip%)]
                   [editor (send snip get-editor)]
                   [show-picts? (not (zero? (send stream-in get-exact)))]
                   [up-to-date? (not (zero? (send stream-in get-exact)))])
              (send editor read-from-file stream-in #f)
              (send snip set-up-to-date up-to-date?)
              (send snip set-show-picts show-picts?)
              (let ([bt (make-hash-table)])
                (let loop ([snip (send editor find-first-snip)])
                  (cond
                    [(is-a? snip snip%)
                     (when (is-a? snip image-snip/r%)
                       (let ([orig (send snip get-orig-snip)]
                             [bm (send snip get-bitmap)])
                         (hash-table-put! bt orig bm)))
                     (loop (send snip next))]
                    [else (void)]))
                (send snip set-bitmap-table bt))
              snip))
          (super-new)))
      
      ;; build-bitmap/check : pict number number (pict dc number number -> void) (any -> boolean) -> bitmap
      ;; called on user-thread with a pict that the user made
      (define (build-bitmap/check pict w h draw-pict pict?)
        (unless (pict? pict) 
          (error 'pict-snip "expected a pict to be the result of each embedded snip, got ~e"
                 pict))
        (let* ([bm (make-object bitmap% 
                     (max 1 (add1 (inexact->exact (ceiling w))))
                     (max 1 (add1 (inexact->exact (ceiling h)))))]
               [bdc (make-object bitmap-dc% bm)])
          (send bdc clear)
          (send bdc set-smoothing 'aligned)
          (draw-pict pict bdc 0 0)
          (send bdc set-bitmap #f)
          bm))
      
      (define (set-box/f b v) (when (box? b) (set-box! b v)))
      
      (define slideshow-bm
        (let ([bm (make-object bitmap% (build-path (collection-path "slideshow") "slideshow.bmp"))])
          (and (send bm ok?)
               bm)))
      
      (define drs-eventspace (current-eventspace))
      
      (define (add-special-menu-item menu frame)
        (let* ([find-insertion-point ;; -> (union #f editor<%>)
                ;; returns the editor (if there is one) with the keyboard focus
                (lambda ()
                  (let ([editor (send frame get-edit-target-object)])
                    (and editor
                         (is-a? editor editor<%>)
                         (let loop ([editor editor])
                           (let ([focused (send editor get-focus-snip)])
                             (if (and focused
                                      (is-a? focused editor-snip%))
                                 (loop (send focused get-editor))
                                 editor))))))]
               [insert-snip
                (lambda (make-obj)
                  (let ([editor (find-insertion-point)])
                    (when editor
                      (let ([snip (make-obj)])
                        (send editor insert snip)
                        (send editor set-caret-owner snip 'display)))))]
               [demand-callback ;; : menu-item% -> void
                ;; enables the menu item when there is an editor available.
                (lambda (item)
                  (send item enable (find-insertion-point)))])
          (instantiate menu:can-restore-menu-item% ()
            (label sc-insert-pict-box)
            (parent menu)
            (demand-callback demand-callback)
            (callback 
             (lambda (menu evt)
               (insert-snip 
                (lambda () (new pict-snip%))))))))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;;  wire it up
      ;;
      
      (define (phase1) (void))
      (define (phase2) (void))
      
      (define orig-namespace (current-namespace))
      
      (define (pict->image-snip p)
        (let* ([pict-width  (dynamic-require 'texpict/mrpict 'pict-width)]
               [pict-height (dynamic-require 'texpict/mrpict 'pict-height)]
               [draw-pict   (dynamic-require 'texpict/mrpict 'draw-pict)]
               [bm (make-object bitmap%
                     (max 1 (add1 (inexact->exact (ceiling (pict-width p)))))
                     (max 1 (add1 (inexact->exact (ceiling (pict-height p))))))]
               [bdc (make-object bitmap-dc% bm)])
          (send bdc clear)
          (send bdc set-smoothing 'aligned)
          (draw-pict p bdc 0 0)
          (send bdc set-bitmap #f)
          (make-object image-snip% bm)))
      
      (drscheme:language:add-snip-value
       ;; Convert to print?
       (lambda (x) 
         ;; if the require fails, then we cannot display the pict.
         ;; this can happen when, for example, there is no mred module
         ;; in the namespace
         (let ([pict? (with-handlers ((exn? (λ (x) #f)))
                        (dynamic-require 'texpict/mrpict 'pict?))])
           (and pict?
                (pict? x))))
       ;; Converter:
       pict->image-snip
       ;; Namespace setup:
       (λ () 
         (with-handlers ((exn? void))
           ;; code running in this thunk cannot fail, or else drscheme gets wedged.
           (dynamic-require 'texpict/mrpict #f))))
        
      (define lib-pict-snipclass (make-object lib-pict-snipclass%))
      (send lib-pict-snipclass set-version 2)
      (send lib-pict-snipclass set-classname (format "~s" '(lib "pict-snipclass.ss" "slideshow")))
      (send (get-the-snip-class-list) add lib-pict-snipclass))))