;;
;; goal: 
;; - write 
;; - compute
;; - make the computer do its best
;; - (voxel zero? end-of-time resolve unexec timeout end-of-time)
;;
;; ~/src/epsilon/
;;
;; (url "http://openvibe.inria.fr/features/")
;; (url "http://freeimage.sourceforge.net/features.html")
;; (url "http://splashcon.org/2013/")
;;
(use-modules (ice-9 optargs))
(use-modules (ice-9 pretty-print))


(define* (zero? . others)
  zero?)


(define* (print . others)
  (write others)
  (newline))


(define* (comment . others) (print others))
(define* (reference-needed . others) (print others))
(define* (debug . others) (print others))
(define* (info . others) (print others))
(define* (warning . others) (print others))
(define* (error . others) (print others))
(define* (critical . others) (print others))
(define* (hack . others) (print others))


;; time! time! time!
(define time '())


;; oops!
(define (reset)
  (set! time '()))

;; tango color palette from (url "/usr/share/emacs/24.3/etc/themes/tango-dark-theme.el")
;;
;; (butter-1 "#fce94f") (butter-2 "#edd400") (butter-3 "#c4a000")
;; (orange-1 "#fcaf3e") (orange-2 "#f57900") (orange-3 "#ce5c00")
;; (choc-1 "#e9b96e") (choc-2 "#c17d11") (choc-3 "#8f5902")
;; (cham-1 "#8ae234") (cham-2 "#73d216") (cham-3 "#4e9a06")
;; (blue-1 "#729fcf") (blue-2 "#3465a4") (blue-3 "#204a87")
;; (plum-1 "#ad7fa8") (plum-2 "#75507b") (plum-3 "#5c3566")
;; (red-1 "#ef2929")  (red-2 "#cc0000")  (red-3 "#a40000")
;; (alum-1 "#eeeeec") (alum-2 "#d3d7cf") (alum-3 "#babdb6")
;; (alum-4 "#888a85") (alum-5 "#555753") (alum-6 "#2e3436")
;; ;; Not in Tango palette; used for better contrast.
;; (cham-0 "#b4fa70") (blue-0 "#8cc4ff") (plum-0 "#e6a8df")
;; (red-0 "#ff4b4b")  (alum-5.5 "#41423f") (alum-7 "#212526"))

(define (time:set! key value)
  (show "settings" key "to" value)
  (set! time (assoc-set! time key value))
  value)

(define (time:get key)
  (assoc-ref time key))


(define (time:show-rec map)
  (if (not (empty-list? map))
      (and (show "time:" (object->string (car map))) (time:show-rec (cdr map)))))
  

(define (time:show)
  (time:show-rec time))

(define (voxel-string depth string)
  (if (eq? depth 0)
      string
      (voxel-string (- depth 1) (string-append string "    "))))

(define (object->string object)
  (if (list? object) (objects->string object)
      (cond ((string? object) object)
	    ((pair? object) (string-append (object->string (car object)) " => " (object->string (cdr object))))
	    ((symbol? object) (string-append "'" (symbol->string object)))
	    ((procedure? object) (string-append "(procedure " (symbol->string (procedure-name object)) ")"))
	    ((boolean? object) (if object "#t" "#f"))
	    (else "[oops]"))))

(define (objects->string-rec objects strings)
  (if (empty-list? objects)
      (string-append "(list " (string-join (reverse strings) " ") ")")
      (objects->string-rec (cdr objects) (cons (object->string (car objects)) strings))))

(define (empty-list? l)
  (if (pair? l)
      #f
      (or (not l) (eq? (length l) 0) (eq? l '()) (eq? l #nil))))

(define (objects->string objects)
  (if (empty-list? objects)
      "[empty]"
      (objects->string-rec objects '())))

(define (voxel-depth->string)
  (voxel-string voxel-depth ""))

(define (show-rec objects string)
  (if (empty-list? objects) 
      (display string)
      (show-rec (cdr objects) (string-append string " " (object->string (car objects))))))

(define (show . args)
  (show-rec args "")
  (newline))

(define (show-past args)
  (show "past is" (past->string args)))


(define (voxel-name x)
  (string->symbol (symbol->string x)))

(define (make-voxel attribute)
  (letrec ((new-voxel (lambda (past future)
		     (voxel (cons voxel (cons new-voxel past)) future))))
    (set-procedure-property! new-voxel 'name (voxel-name attribute))
    new-voxel))

(define (resolve-symbol attribute)
  (if (time:get attribute) (time:get attribute)
      (let ((time-voxel (make-voxel attribute)))
	(show "fuuu" time-voxel)
	(time:set! attribute time-voxel)
	time-voxel)))

(define (voxel-resolve-procedure procedure)
  ;; if it's voxel ie. in the time
  ;; else convert it -- to a root voxel
  (let ((name (procedure-name procedure)))
	(if (time:get name)
	    procedure
	    (time:set! name procedure))))

(define (voxel-resolve-next next)
  (cond ((symbol? next) (resolve-symbol next))
	((procedure? next) (voxel-resolve-procedure next))
	(else (string-append "voxel-resolve-next failed with " (object->string next)))))

(define (voxel-resolve-future past future)
  (letrec ((next (car future))
	   (future-tail (cdr future))
	   (next-voxel (voxel-resolve-next next)))
    (time:set! 'current next-voxel)
    (next-voxel past future-tail)))

(define voxel-depth 0)

(define (voxel-depth-inc)
  (set! voxel-depth (+ 1 voxel-depth))
  voxel-depth)

(define (voxel-depth-reset)
  (set! voxel-depth 0))

(define (entering-voxel past future)
  (show "entering voxel")
  (show "past is" (objects->string past))
  (show "future is" (objects->string future))
  (show "end of showing voxel"))

(define (empty-past? past)
  (empty-list? past))

(define (empty-future? future)
  (empty-list? future))

(define (voxel past future . args)
  (entering-voxel past future)
  (if (empty-past? past)
      (if (empty-future? future)
	  voxel  ;; case voxel is called alone with no future and no past
	  (voxel-resolve-future past future))
      ;; handle voxels with history
      ;; resolve next voxel if any
      ;; 
      (if (empty-future? future)
	  (and (time:set! (reverse past) #t) voxel)
	  (voxel-resolve-future past future))))

(voxel 'key define)

;; example override of a voxel
(define (end-of-time past future)
  (voxel (cons end-of-time past) future)
  (show "> end of time")
  (time:show)
  (time:reset)
  (show "> end of time"))


(define (testing past future)
  (voxel (cons testing past) future))