;; -*- scheme -*-

;;=====================================================================
;;
;;                     Chalice-Gimp Protocol
;;
;;  A set of routines that create and interact with a session object
;;
;;=====================================================================

;; Create/edit the script in a gimp node
(define chalice-start
  (lambda (_script _node . args)
    (let ((s (make-session 'interactive)))
      ((s 'init) _script _node)
      ((s 'verify))
      ((s 'exec))
      ((s 'show))
      (add-session 'interactive s)
      #f)))

;; Get the latest script for the node being edited
(define chalice-retrieve
  (lambda ()
    (let ((s (get-session 'interactive)))
      ((s 'sync))
      ((s 'verify))
      ((s 'get-script)))))

;; Terminate an interactive editing session
(define chalice-stop
  (lambda ()
    (let ((s (get-session 'interactive)))
      ((s 'kill))
      #f)))

;; Make sure the node is in a valid state
(define chalice-verify
  (lambda (_script _node . args)
    (let ((s (make-session 'batch)))
      ((s 'init) _script _node)
      ((s 'verify))
      ((s 'kill))
      #f)))

;; Execute the node script in non-interactive id
(define chalice-execute
  (lambda (_script _node . args)
    (let ((s (make-session 'batch)))
      ((s 'init) _script _node)
      ((s 'verify))
      ((s 'exec))
      ((s 'kill))
      #f)))


;;=====================================================================
;;
;;                      Session List
;;
;;=====================================================================

(define session-list '())

(define (get-session id)
  (let ((s (assq id session-list)))
    (or (pair? s)
        (throw 'session-does-not-exist id))
    (cadr s)))

(define (add-session id session)
  (set! session-list
        (cons (list id session)
              session-list)))

(define (remove-session id)
  (set! session-list
        (delq (assq id session-list)
              session-list)))

(define (session-exists? id)
  (assq id session-list))



;;=====================================================================
;;
;;                           Session
;;
;;  A mediator that creates and manages several subobjects.
;;
;;    node   - inputs/outputs for chalice node
;;    script - the recorded macro
;;    gimp   - gimps internal state
;;
;;=====================================================================

(define (make-session id)

  (if (session-exists? id)
      (throw 'session-already-exists id))

  (let* ((gimp #f)
         (node #f)
         (script #f))
    
    ;; given a freshly created image in gimp and a macro we've
    ;; received from chalice, play back the macro
    (define (exec)
      ((gimp 'exec-macro) ((script 'get)))
      #f)

    ;; ask the script object for the macro
    (define (get-script)
      ((script 'get)))

    ;; create our internal state from the script and node objects we
    ;; received from chalice
    (define (init _script _node)
      (set! gimp (make-gimp))
      (set! node (make-node _node))
      (set! script (make-script gimp node _script))
      ((gimp 'init) node)
      #f)

    ;; shut down
    (define (kill)
      (remove-session id)
      ((gimp 'stop-macro))
      ((gimp 'kill))
      #f)

    ;; pop up the window and start recording
    (define (show)
      ((gimp 'show))
      ((gimp 'start-macro))
      #f)

    ;; stop recording, gather up the results, and start recording
    ;; again
    (define (sync)
      ((gimp 'stop-macro))
      ((script 'add) ((gimp 'get-macro)))
      ((gimp 'start-macro))
      #f)

    ;; make sure all the internal state looks good
    (define (verify)
      (or (and node script gimp)
          (throw 'bad-internal-state "run away..."))
      #f)

    
    ;; the session object
    (lambda (cmd)
      (cond
       ((eq? cmd 'exec)       exec)
       ((eq? cmd 'get-script) get-script)
       ((eq? cmd 'init)       init)
       ((eq? cmd 'kill)       kill)
       ((eq? cmd 'show)       show)
       ((eq? cmd 'sync)       sync)
       ((eq? cmd 'verify)     verify)
       (#t (oops "session"))))))


  

;;=====================================================================
;;
;;                      Gimp State
;;
;;  Handle invoking script-fu operations
;;
;;=====================================================================

(define (make-gimp)

  (let ((gimage -1)
        (gdisplay -1))

    (define (add-layer l)
      (let ((layer (car (apply gimp-layer-new
                               (cons gimage (car l))))))
        (gimp-drawable-fill layer TRANS-IMAGE-FILL)
        (gimp-image-add-layer gimage layer 0)
        (if (not (null? (cdr l)))
            (let ((mask (car (apply gimp-layer-create-mask
                                    (cons layer (cadr l))))))
              (gimp-image-add-layer-mask gimage layer mask)))))

    (define (init node)
      (set! gimage (car (apply gimp-image-new (node 'image))))
      (map add-layer (node 'layers)))

    (define (show)
      (if (eqv? gimage -1)
          (throw 'gimp-show "No gimage"))
      (set! gdisplay (car (gimp-display-new gimage))))

    (define (kill)
      (or (eqv? gdisplay -1)
          (begin
            (gimp-display-delete gdisplay)
            (set! gdisplay -1)
            (set! gimage -1)))
      (or (eqv? gimage -1)
          (begin
            (gimp-image-delete gimage)
            (set! gimage -1))))
    


    (define (start-macro)
      (gimp-macro 1 "the-macro.trace"))
    
    (define (stop-macro)
      (gimp-macro 0 "the-macro.trace"))
    
    (define (get-macro)
      #f)
    
    (define (exec-macro s)
      #f)
    
    (lambda (cmd)
      (cond       
       ((eq? cmd 'init) init)
       ((eq? cmd 'show) show)
       ((eq? cmd 'kill) kill)
       ((eq? cmd 'start-macro) start-macro)
       ((eq? cmd 'stop-macro) stop-macro)
       ((eq? cmd 'get-macro) get-macro)
       ((eq? cmd 'exec-macro) exec-macro)
       (#t (oops "gimp"))))))



;;=====================================================================
;;
;;                          Node
;;
;;  An image which the macro will be played back on.
;;
;;=====================================================================

(define (make-node _node)

  (let* ((layers ())
         (image ()))

    ;; make sure node looks valid
    (define (arg-is-bad)

      (define (image-ok? i)
        #t)
      
      (define (layer-ok? l)
        #t)
      
      (define (mask-ok? m)
        #t)
      
      ;; check a single input
      (define (value-ok? v)
        (cond
         ((eq? (car v) 'image) (image-ok? (cdr v)))
         ((eq? (car v) 'layer) (layer-ok? (cdr v)))
         ((eq? (car v) 'mask)  (mask-ok? (cdr v)))
         (#t #f)))

      ;; make sure the list of inputs looks kosher
      (define (values-ok? v)
        (or (null? v)
            (and (value-ok? (car v))
                 (values-ok? (cdr v)))))
      
      ;; check the order of the various inputs using a small state machine
      (define (ordering-ok? tags state)
        (if (null? tags)
            (> state 1)
            (let ((x (list (car tags) state)))
              (cond
               ((equal? x '(image 0)) (ordering-ok? (cdr tags) 1))
               ((equal? x '(layer 1)) (ordering-ok? (cdr tags) 2))
               ((equal? x '(layer 2)) (ordering-ok? (cdr tags) 2))
               ((equal? x '(mask 2))  (ordering-ok? (cdr tags) 3))
               ((equal? x '(layer 3)) (ordering-ok? (cdr tags) 2))
               (#t #f)))))
      
      (not
       (and (pair? _node)
            (eq? (car _node) 'node)
            (ordering-ok? (map car (cdr _node)) 0)
            (values-ok? (cdr _node)))))


    ;; parse the _node argument and save the results so we can make a
    ;; layer stack out of them later
    (define (parse-node)
      (let* ((i (cadr _node))
             (l (cddr _node))
             (width (cadr i))
             (height (caddr i))
             (type (cadr (cddr i))))
        
        (define (layer l)
          (list width
                height
                (cond ((eq? type 'RGB)  RGBA_IMAGE)
                      ((eq? type 'GRAY) GRAYA_IMAGE))
                "Foo"
                100
                NORMAL))

        (define (mask m)
          (list WHITE-MASK))
        
        (define (parse-layers l)
          (cond
           ((null? l) (throw 'parse-layers "no layers!"))
           ((null? (cdr l)) (list (list (layer (car l)))))
           ((eq? 'layer (caadr l)) (cons (list (layer (car l)))
                                         (parse-layers (cdr l))))
           (#t (cons (list (layer (car l))
                           (mask (cadr l)))
                     (parse-layers (cddr l))))))
        
        (set! layers (parse-layers l))
        (set! image (list width
                          height
                          (cond ((eq? type 'RGB)  RGB)
                                ((eq? type 'GRAY) GRAY))))))
    
    
    (if (arg-is-bad)
        (oops "node")
        (begin
          (parse-node)
          (lambda (cmd)
            (cond
             ((eq? cmd 'image)   image)
             ((eq? cmd 'layers)  layers)
             (#t (oops "node"))))))))
  
  

;;=====================================================================
;;
;;                          Script
;;
;;  A recorded macro.
;;
;;=====================================================================

(define (make-script gimp node _script)

  (define (get)
    _script)

  (define (add s)
    (write-line "not implemented")
    #f)

  (define (arg-is-bad)
    #f)

  (if (arg-is-bad)
      (oops "script")
      (lambda (cmd)
        (cond
         ((eq? cmd 'get)     get)
         ((eq? cmd 'add)     add)
         (#t (oops "script"))))))


;;=====================================================================
;;
;;                        Misc Stuff
;;
;;=====================================================================

(define (return-no . args)
  #f)

(define (return-yes . args)
  #t)

(define (oops class)
  (lambda (. args)
    (write-line (string-append class ": unknown command"))
    #f))

(define nuke
  (lambda ()
    (map (lambda (i) (gimp-display-delete i))
         (array->list (cadr (gimp-display-list))))
    (map (lambda (i) (gimp-image-delete i))
         (array->list (cadr (gimp-list-images))))))
