; -*- scheme -*-


(define (trace->macro trace macro)
  (with-input-from-file trace
    read-the-trace-file)
  (with-output-to-file macro
    and-create-the-macro-file))

(define (read-the-trace-file)
  (make-script-from
   (the-optimized
    (input-file))))

(define (and-create-the-macro-file)
  (print-the-vars)
  (and-the-body)
  (and-the-registration))

(define (make-script-from file)
  (map (lambda (l)
         (parse l parsers))
       (reverse file)))

(define (the-optimized l)
  (cond
   ((null? l) '())
   ((null? (cdr l)) l)
   (else
    (let ((first (car l))
          (next (cadr l)))
      (if (and (eq? (car first) (car next))
               (eq? (cadr first) (cadr next)))
          (the-optimized (cons first (cddr l)))
          (cons first (the-optimized (cdr l))))))))

(define (input-file)
  (let ((file ()))
    (define (parse)
      (let ((line (read)))
        (cond
         ((eof-object? line) file)
         (else (set! file (cons line file))
               (parse)))))
    (parse)))

(define (print-the-vars)
  (write (macro-vars 'dump))
  (newline)
  (newline))

(define (and-the-body)
  (write `(define (macro-body ,@(macro-parms 'names))
            ,@(apply append (macro-steps 'get))))
  (newline)
  (newline))

(define (and-the-registration)
  (write `(script-fu-register "macro-body"
                              "<Toolbox>/Xtns/Macros/Run"
                              "Run the macro"
                              "Ray Lehtiniemi <rayl@gimp.org>"
                              "Ray Lehtiniemi"
                              "03/27/99"
                              ""
                              ,@(apply append (macro-parms 'types))))
  (newline)
  (newline))




;;------------------------------------------------------------

(define (parse line parsers)
  (let ((handler (assq-ref parsers (car line))))
    (if handler (apply (eval handler) (cdr line)))))

(define parsers
  '(
    (brush . parse-brush)
    ;(clone . parse-clone)
    ;(paintbrush . parse-paintbrush)
    (palette . parse-palette)
    (pattern . parse-pattern)
    ;(strokes . parse-strokes)
    ;(stroke . parse-stroke)
    ))


(define (make-pdb cmd . args)
  (macro-steps 'add
               `(,cmd ,@args)))

(define (make-var type val)
  (macro-vars 'add
              type val))

(define (make-parm type name default)
  (macro-parms 'add
               `(,type ,name ',default)))



;; the guts of the parser.  each routine parses a particular type of
;; line from the trace file.

(define (parse-brush cmd . args)
  (case cmd

    ((select)
     (let ((x (make-parm 'SF-BRUSH "Brush" args)))
       (make-pdb `(gimp-brushes-set-brush ,(macro-parms 'name x)))))

    ((spacing)
     (let ((x (make-var 'brush-spacing (car args))))
       (make-pdb `(gimp-brushes-set-spacing (macro-vars 'get ,x)))))
    
    ((opacity)
     (let ((x (make-parm 'SF-VALUE "opacity" (number->string (car args)))))
       (make-pdb `(gimp-brushes-set-opacity ,(macro-parms 'name x)))))
    
    ((paintmode)
     (make-pdb `(gimp-brushes-set-paint-mode ,(car args))))))



(define (parse-palette cmd . args)
  (case cmd

    ((foreground)
     (let ((x (make-parm 'SF-COLOR "foreground" args)))
       (make-pdb `(gimp-palette-set-foreground ,(macro-parms 'name x)))))

    ((background)
     (let ((x (make-parm 'SF-COLOR "background" args)))
       (make-pdb `(gimp-palette-set-background ,(macro-parms 'name x)))))))


(define (parse-pattern cmd . args)
  (case cmd
    
    ((select)
     (let ((x (make-parm 'SF-PATTERN "pattern" (car args))))
       (make-pdb `(gimp-patterns-set-pattern ,(macro-parms 'name x)))))))


;;------------------------------------------------------------

;; the parsed steps of the trace file.  generally these correspond
;; pretty closely to registered PDB functions.

(define macro-steps
  (let ((steps ()))

    (define (add args)
      (set! steps (append! args steps)))

    (lambda (cmd . args)
      (case cmd
        ((add)      (add args))
        ((get)      (reverse steps))
        ((optimize) (set! steps (optimize steps)))
        ))))


;; the vars.  these guys have to be looked up at run time since they
;; might not exist when the script is loaded.  eg: ids of layers
;; created in the middle of a macro.

(define macro-vars
  (let ((by-data ())
        (by-num ())
        (count 0))

    (define (add args)
      (let ((x (assoc args by-data)))
        (if x
            (cdr x)
            (begin
              (set! count (1+ count))
              (set! by-data (acons args count by-data))
              (set! by-num (acons count args by-num))
              count))))

    (define (dump)
      ;; this code gets executed in script-fu, not guile, so it can't
      ;; use the 'case' syntax
      `(define (macro-vars cmd . args)
         (let ((vals ',by-num))
           (cond
             ((eq? cmd 'get) (caddr (assq (car args) vals)))
             ((eq? cmd 'raw) vals)
             ))))

    (lambda (cmd . args)
      (case cmd
        ((add)    (add args))
        ((dump)   (dump))
        ))))


;; the parms.  these guys will need to correspond to the types in
;; script-fu-enums.h

(define macro-parms
  (let ((by-data ())
        (by-num ())
        (count 0))

    (define (add args)
      (let ((x (assoc args by-data)))
        (if x
            (cdr x)
            (begin
              (set! count (1+ count))
              (set! by-data (acons args count by-data))
              (set! by-num (acons count args by-num))
              count))))

    (define (name x)
      (string->symbol (string-append "parm" (number->string x))))

    (lambda (cmd . args)
      (case cmd
        ((add)    (add args))
        ((name)   (name (car args)))
        ((names)  (map name (map car (reverse by-num))))
        ((types)  (map cadr (reverse by-num)))
        ))))
























(define (parse-clone cmd . args)
  (case cmd

    ((start)
     (set! pc-args args))

    ((finish)
     (macro-steps 'add
                  `(let* ((drawable  (car (gimp-image-get-layer-by-tattoo img ,(cadr pc-args))))
                          (src       (car (gimp-image-get-layer-by-tattoo img ,(cadddr pc-args))))
                          (strokes   (cons-array ,pc-count 'double)))
                     (scale-stroke strokes 0 ',pc-strokes)
                     (gimp-clone drawable
                                 src
                                 ,@(cddddr pc-args)
                                 ,pc-count
                                 strokes))))))

(define (parse-paintbrush cmd . args)
  (case cmd

    ((start)
     (set! pc-args args))

    ((finish)
     (macro-steps 'add
                  `(let* ((drawable  (car (gimp-image-get-layer-by-tattoo img ,(cadr pc-args))))
                          (strokes   (cons-array ,pc-count 'double)))
                     (scale-stroke strokes 0 ',pc-strokes)
                     (gimp-paintbrush-extended drawable
                                               ,(caddr pc-args)
                                               ,pc-count
                                               strokes
                                               ,(caddr (cddr pc-args))))))))

    
;; paint core arguments
(define pc-args ())
(define pc-count 0)
(define pc-strokes ())

(define (parse-strokes cmd . args)
  (case cmd
    
    ((start)
     (set! pc-count (* 2 (car args)))
     (set! pc-strokes '()))
    
    ((finish)
     #f)))

(define (parse-stroke cmd . args)
  (set! pc-strokes (append pc-strokes args)))




