#lang racket
(provide 
         call-exp-fun eqn= 
         unknown-numeric 
         unknown-point
         unknown-color
;;         unknown-path
         unknown-transform
         unknown-picture
         unknown-object
         )
(provide def-exp)
;; ----------------------------
(require (planet wcy/anaphora))
(require "mpost-utils.rkt")
(require "mpost-type-funs.rkt")
(require "mpost-interface.rkt")
(require "mpost-new-name.rkt")
(define (unknown-object type)
  (let* ((ret (new-var (char->string (type->char type)))))
    (insert (to-string (list type ret ";\n" )))
    ret))
(define (unknown-numeric) (unknown-object 'numeric))
(define (unknown-point) (unknown-object 'pair))
(define (unknown-color) (unknown-object 'color))
(define (unknown-transform) (unknown-object 'transform))
(define (unknown-picture)
  (let ((pic (unknown-object 'picture)))
    (insert pic ":= nullpicture;\n")
    pic))
(define all-type-def
  '((#\x numeric)
    (#\z pair)
    (#\c color)
    (#\p path)
    (#\P picture)
    (#\T transform)
    (#\q pen)
    (#\s string)
    (#\b boolean)))
(define (get-type object)
  (match (to-string object)
    ("green" 'color)
    ("red" 'color)
    ("blue" 'color)
    ("white" 'color)
    ("cycle" 'pair)
    ("pencircle" 'pen)
    ("evenly" 'picture)
    ("withdots" 'picture)
    ("up" 'pair)
    ("down" 'pair)
    ("right" 'pair)
    ("left" 'pair)
    ("fullcircle" 'path)
    ((regexp #rx"^-?[0-9]+.*$") 'numeric)
    ((regexp #rx"^([xzcpPTqsb])[a-z]*$" (list _ type)) 
     (char->type (string-ref type 0)))
    (otherwise 'unknown-type)))
(define (rassoc a lst)
  (findf (compose (curry equal? a) cadr) lst))
(define (char->type char)
  (aand (assoc char all-type-def) (cadr it)))
(define (type->char type)
  (aand (rassoc type all-type-def) (car it)))
(define (call-exp-fun-no-cache return-type value)
  (let ((my-name (unknown-object (return-type))))
    (case (get-type my-name)
      ((path picture) (insert my-name ":=" value ";\n"))
      (else (eqn= my-name value)))
    my-name))
(define (call-exp-fun return-type f)
  (let ((value (f)))
    (or (cache-value value)
        (def-cache-value value (call-exp-fun-no-cache return-type value)))))
(define (eqn= . ps)
  (insert (apply (op-concat " = ") ps) ";\n"))
(define-syntax def-exp 
  (lambda (stx)
    (syntax-case stx ()
      ((_ (name es ... . lep) (type ...) body ...)
       (with-syntax ((le (if (identifier? #'lep) 
                             #'(map get-type lep)
                             #''())))
         #'(define (name  es ... . lep)
             (parameterize ([current-stack (cons (list 'code: '(name es ... . lep) 
                                                       'value: (list es ... le)
                                                       'type: '(type ...))
                                                 (current-stack))])
               (call-exp-fun
                (lambda ()  (apply 
                             (check-type type ... )
                             (get-type es) ... le))
                (lambda () body ...)))))))))