;; ip - image processing compiler

;; this is yet another attempt to create a compiler for video/image
;; processing operations.

;; the idea is to specify a processor as
;; - a set of low level pixel operations
;; - a control structure

;; the idea is to create a weaver that generates a compiled processor
;; given other constraints (image size, tile size, bit depth, ...)


;; the language used here consists of nested expressions:
;; (operator . args)
;; (grid . index)
;; constant

;; so, if it's not a constant or a primititive operator, it's a grid
;; input. this is easily extended to composite operators as:


(require (lib "match.ss"))
(require "list-utils.ss")
(require "tree-utils.ss")
(require "cgen.ss")

(begin


  ;; ip programs consist of opertors and grids. currently, operators
  ;; are fixed (primitive), but later they can come from a different
  ;; name space.
  
  (define (ip-operator? x)
    (case x
      ((+ - / * abs) #t)    ;; primitive math ops
      ((statements =) #t)        ;; intermediate rep keywords
      (else #f)))


  ;; ANALYSIS

  ;; code transformer mapping. instead of using an adt, this visitor
  ;; will abstract code structure. (this is the parser)

  ;; (set-selective-display 3)
 (define (make-src-iterator _cons _map)
    (lambda (fn-grid
             fn-operator
             fn-constant
             src)
      (let down ((s src))
        (match s
               ;; operand -> recurse
               (((and op (= ip-operator? #t)) . args)
                (_cons (fn-operator op)
                       (_map down args)))
               ;; grid
               ((name . index) (fn-grid s))

               ;; constants
               (c (fn-constant c))))))

  (define src-map (make-src-iterator cons map))
  (define src-for (make-src-iterator void for-each))

  (define (grid-map fn src) (src-map fn id id src))
  
                 


  
  ;; get a list of grid dimensions from a source text
  (define (src->grids src)

    (let ((grids '())) ;; linear accumulator

      (define (register! grid/index)
        (let ((grid/dims ((dip length) grid/index))
              (already (assoc (car grid/index) grids)))
                 
          (if (not already)
              (push! grids grid/dims)
              (if (not (equal? already grid/dims))
                  (error 'invalid-dimensions
                         "new: ~a, was: ~a"
                         grid/dims
                         already)))))

      (src-for register! void void src)
      grids))



  ;; compute output dimension
  (define (grids->dim grids)
    (apply max (map cdr grids)))

  (define (src->dim src)
    (grids->dim (src->grids src))) 


  
  ;; C CODE GENERATION


  ;; format loop body indented: indentation reflects number of free
  ;; loop variables in expression.
  
  ;; TODO: solve most things as C syntax extensions


  ;; stride / size : generate symbolic C code, gcc will optimize away
  ;; for literals.
  
  (define multiply-expression
    (match-lambda
     (() 1)
     ((a) a)
     ((a . r) `(* ,a ,(multiply-expression r)))))

  (define (num=? x n)
    (and (number? x)
         (= x n)))

  (extend-expressions
   (transformer
    
    (define (grid ptr) `(* ,ptr))
    (define (loop  s)   s)        ;; ignore

    ))
  

  (define (pad-indices index dim)
    (if (< (length index) dim)
        (pad-indices (cons 0 index) dim)
        index))



  ;; synthesize variable name for computed pointer
  (define (offset->name base offset)
    (string->symbol
     (format "~s_~s~s"
             base
             (if (< offset 0) 'm 'p)
             (abs offset))))

  (define (expand-for-loop dim/range bindings body)
    (let ((loopvar (caar dim/range))
          (range (map cdr dim/range)))
      
      `(block
        (var int ,loopvar)
        (for-head (=  ,loopvar 0)
                  (<  ,loopvar ,(multiply-expression range))
                  (+= ,loopvar ,(multiply-expression (cdr range))))
        (block
         (vars ,@bindings)
         ,body))))

  (define (expand-pointer-init dim/range a offset)
      (let ((range (map cdr dim/range)))
        `(+ ,a
            (+ ,(caar dim/range)
               ,(multiply-expression (cons offset (cdr range)))))))


  
  ;; push a relative expression through a binding block
  (define (expand-loop-body type loop-sexp dim/range)
    (call-with-collector
     
     (lambda (binding!)
       (substitute* (tag? grid)
                    (lambda (tag name offset . o)
                      (let ((bound-name
                             (offset->name name offset)))
                        
                        ;; collect binding for first index
                        (binding! `(,type ,bound-name
                                          ,(expand-pointer-init
                                            dim/range
                                            name
                                            offset)))
                        
                        ;; leave remaining indices + bound name
                        `(grid ,bound-name ,@o)))
                    loop-sexp))
     
     (lambda (body bindings)
       (expand-for-loop dim/range bindings body))))
  
     

  ;; expand a body expression once

  ;; this expands a 'loop' form once, peeling off the toplevel loop
                             
  
  ;; expand source file to nested loop expression, with a number of
  ;; indexers per level, and typed pointers.
  (define (src->statement src        ;; assigment expression
                          expanders  ;; inner clause expansion
                          type       ;; pointer type
                          dim/range  ;; dimension (name . range)
                          )
                          

    ;; - tag grid expressions
    ;; - pad dimensions
    ;; - tag loop
    
    ;; tag for use with 'substitute' + 
    (define (init src)
      (list 'loop  ;; tag toplevel 'loop
            (let ((maxdim (length dim/range)))
              (grid-map
               (match-lambda
                ((name . indices)
                 `(grid ,name ;; tag 'grid
                        ,@(pad-indices indices maxdim))))
               src))))

    ;; generate C code by expanding the 'loop' sexps once for each
    ;; dimension.
    
    (let next ((d/r dim/range)
               (s   (init src)))

      (if (null? d/r) s    ;; no more dims
          (next (cdr d/r)
                
                ;; expand one loop level
                (substitute
                 (tag? loop)
                 (lambda (loop-body)
                   
                   ;; invoke expanders for this level
                   `(statements
                     ,@(map
                        (lambda (expand)
                          (expand type loop-body d/r))
                        expanders)))
                 
                 s)))))



  (define (src->code src)
    (statement->string
     (src->statement src
                     `(,expand-loop-body)  ;; loop expanders
                     'float*          ;; FIXME: use dynamic binding / C macro
                     ;; '((i . width) (j . hight))
                     '((i . 400) (j . 300))
                     )))

  (define (src->assign out src)
    `(= (,out) ,src))
  
  (define (p src)
    (display (src->code
              (src->assign 'x src))))

)