#lang racket
(require compatibility/mlist)
(require "du-utility.scm")
(require "du-environment.scm")
(require "du-core.scm")
(provide eval-suggest eval-boundary eval-state eval-sign)
;
; new stuff for dontuse: encapsulation, statements
;
(define (check_name_list name-list )
  ; for sign and boundary
  (cond ((syntax? name-list)
         (check_name_list (un-syntax name-list) ))
        ((not (list? name-list))
         (error "Expect a list of names; not a list. -- check_name_list"))
        ((and (not (null? name-list))
              (syntax? (car name-list)))
         (check_name_list (map un-syntax name-list) ))
        ((eq? (length name-list)
              (length (filter symbol? name-list)))
         (cons 'list name-list))
        (else
         (error "Expect a list of names; not all symbols. -- check_name_list"))))

(define (eval-suggest expr xenv)
  ; a NOP that holds information: comments, compiler extensions, FFI, tests, etc.
; TODO suggest
;  (if (some-lookup__ (list-ref expr 1))
;      (do-lookup-stuff__ (list-ref expr 0) (list-ref expr 2))
  (eval0 (car expr) xenv))
;)

(define (eval-export expr xenv)
; TODO export
  #f)
(put 'op 'export eval-export)

(define (eval-import expr xenv)
; TODO import
  #f)
(put 'op 'import eval-import)


(define (eval-sign expr xenv)
  ; rename variables, first one acts as a prefix
; TODO make a 'hide' instruction for the interpreter
;;   (define (extend-hide vars old-env)
;;     ; blocks/hides old names
;;     (define (get-env-extension xenv) (car xenv))
;;     ; imported function
;;     (define (make-frame variables )
;;       (let ((t-list (map (lambda (x) #t) variables)))
;;         (map list variables t-list t-list)))
;;     (cons (get-env-extension old-env) 
;;           (cons (make-frame vars) (get-basic-env old-env))))
  (define (rename-list-o-symb prefix s-list)
    (define (rename-symbol symbol1)
      (string->symbol (string-append
                       (symbol->string prefix)
                       "/" ;TODO don't allow using this in a symbol otherwise
                       (symbol->string symbol1))))
    (extend-environment
     (map rename-symbol s-list)
     (map (lambda (violet) (lookup-variable-value violet xenv)) s-list)
     xenv))
  (cond ((or (null? expr) (not (eq? 3 (length expr))))
         (error "Three arguments expected. -- SIGN" expr))
        ((not (symbol? (un-syntax (car expr))))
         (error "First argument should be a name. -- SIGN" (car expr)))
        ((not (list? (un-syntax (cadr expr))))
         (error "Second argument should be a list. -- SIGN" (cadr expr)))
        ((eq? 0 (length (un-syntax (cadr expr))))
         (error "Second argument should have at least one element. -- SIGN"
                (cadr expr)))
        ((not (eq? (length (filter symbol?
                                   (map un-syntax (un-syntax (cadr expr)))))
                   (length (un-syntax (cadr expr)))))
         (error "Second argument should be a list of names. -- SIGN"
                (map un-syntax (un-syntax (cadr expr)))))
        (else
         (let* ((sy-lst (un-parse-list
                         (map un-syntax (un-syntax (cadr expr)))))
                (environment (rename-list-o-symb (un-syntax (car expr)) sy-lst)))
           (actual-value (caddr expr) environment)))))


(define (get-observers boundary)
  (car boundary))
(define (get-constructors boundary)
  (cadr boundary))
(define (set-p-key! proc qw)
  (set-mcar! (mlist-ref proc 4) qw))
(define (set-p-lock! proc qw)
  (set-mcar! (mcdr (mlist-ref proc 4)) qw))


(define (eval-boundary expr xenv)
  ; form a boundary (aka an encapsulate / interface / access control / abstraction enforcement)
  (define (check-procedure proc-name)
    ; boundary takes functions, if you need a built-in/primitive wrap it in a lambda first
    (if (not (symbol? (un-syntax proc-name)))
        (error "Boundary takes lists of named functions (expected a symbol). -- BOUNDARY"
               (un-syntax proc-name))
        'OK)
    (let ((proc-val (lookup-variable-value (un-syntax proc-name) xenv)))
      (if (compound-procedure? proc-val)
          (if (or (get-p-key proc-val) (get-p-lock proc-val))
              (error "Procedure intersects another boundary. -- BOUNDARY" proc-val)
              proc-val)
          (error "Not a compound procedure. -- BOUNDARY" proc-val))))
  
  (define (lock-proc proc lock)
    ; copy procedure, but add a lock for the boundary
    (list (list-ref proc 0)
          (list-ref proc 1)
          (list-ref proc 2)
          (list-ref proc 3)
          (mlist #f lock #f)))
  
  (define (key-proc proc key)
    ; copy procedure, but add a key for the boundary
    (list (list-ref proc 0)
          (list-ref proc 1)
          (list-ref proc 2)
          (list-ref proc 3)
          (mlist key #f #f)))
  
  (if (or (null? expr) (not (eq? (length expr) 3)))
      (error "Three arguments expected. -- BOUNDARY" expr)
      'ok)
  (let* ((arg1 (un-parse-list (un-syntax (list-ref expr 0))))
         (arg2 (un-parse-list (un-syntax (list-ref expr 1))))
         (both-p&c  (filter (lambda (ant) (member ant arg2)) arg1))
         (producer-n (filter (lambda (thistle) (not (member thistle both-p&c))) arg1))
         (consumer-n (filter (lambda (chicory) (not (member chicory both-p&c))) arg2))
         (check-stuff
          (cond
            ((and (not (list? arg1)) (eq? (length arg1) 0))
             (error "No producers (first argument) -- BOUNDARY" arg1))
            ((and (not (list? arg2)) (eq? (length arg2) 0))
             (error "No consumers (second argument) -- BOUNDARY" arg2))
            ((eq? 1 (length both-p&c))
             (error "Producer is a consumer -- BOUNDARY" (car both-p&c)))
            ((> (length both-p&c) 0)
             (error "Producers are consumers -- BOUNDARY" both-p&c))
            (else
             'OK)))
         (producer-f (map check-procedure producer-n))
         (consumer-f (map check-procedure consumer-n))
         (new-boundary (begin (put 'globals 'boudary
                                   (+ 1 (get 'globals 'boudary)))
                              (get 'globals 'boudary)))
         (boundary-names (append producer-n consumer-n))
         (boundary-values (append
                           (map
                            (lambda (marigold) (lock-proc marigold new-boundary))
                            producer-f)
                           (map
                            (lambda (lilac) (key-proc lilac new-boundary))
                            consumer-f))))
    (eval0 (list-ref expr 2)
           (extend-environment boundary-names boundary-values xenv))))


(define (eval-state exps xenv) 
  ; a sequence of statements / an embeded imperative sub-language
  ; sequence ((<label> <statement>* )+ ) ((<name> <value>)+ )
  (define jump-table (list))
  (define statement-seq (list))
  (define current-stmt 0)
  (define memory (mlist)) ; could use a multi splay tree for better performance
  (define (init-memory ex)
    (set! memory (list->mlist
                  (un-parse-list
                   (map
                    (lambda (grub) (un-syntax grub))
                    (un-syntax (list-ref ex 1)))))))
  (define (return-memory)
    (mlist->list memory))
  
  (define (memory-cell location)
    (define (get-cell place mem)
      (cond ((null? mem) (error "Memory cell not found. -- STATE"))
            ((equal? place (mcar mem)) (mcdr mem))
            (else (get-cell place (mcdr (mcdr mem))))))
    (get-cell location memory))
  
  (define (load-s env) 
    ; read from the environment to internal memory
    (set-mcar! (memory-cell
                (list-ref statement-seq (+ 1 current-stmt)))
               (actual-value (list-ref statement-seq (+ 2 current-stmt)) env)))
  
  (define (store-s env)
    ; write to the environment from internal memory
    (define (deep-copy s-exp)
      (define (seed s-exp)
        (if (pair? s-exp)
            (cons (seed (car s-exp)) (seed (cdr s-exp)))
            s-exp))
      (seed s-exp))
    (define new-value (deep-copy (mcar (memory-cell
      (list-ref statement-seq (+ 1 current-stmt))))))
    (extend-environment 
      (list (list-ref statement-seq (+ 2 current-stmt)))
      (list new-value)
      xenv))
  
  (define (jump-s env)
    ; GOTO label / location
    (let* ((label (string->symbol
                   (actual-value
                    (list-ref statement-seq (+ 1 current-stmt))
                    env)))
           (goto (assoc label jump-table)))
    (set! current-stmt (cadr goto))))
  
  (define (event-s env)
    ; do some event
    (if (get 'event (list-ref statement-seq (+ 1 current-stmt)))
        (set-mcar! (memory-cell
                    (list-ref statement-seq (+ 2 current-stmt)))
                   ((get 'event (list-ref statement-seq (+ 1 current-stmt)))
                    (mcar (memory-cell
                           (list-ref statement-seq (+ 2 current-stmt))))
                    (list-ref statement-seq (+ 3 current-stmt))))
        (error "Not a registered event. -- STATE")))
  
  (define (eval-s environment) 
      (cond ((> (+ 1 current-stmt) (length statement-seq)) 
              (return-memory))
            ((equal? 'event (list-ref statement-seq current-stmt)) 
              (begin (event-s environment) 
                     (set! current-stmt (+ 4 current-stmt))
                     (eval-s environment)))
            ((equal? 'store (list-ref statement-seq current-stmt)) 
              (let ((new-environment (store-s environment)))
                (begin
                     (set! current-stmt (+ 3 current-stmt))
                     (eval-s new-environment))))
            ((equal? 'load  (list-ref statement-seq current-stmt)) 
              (let ((new-env (load-s environment)))
              	   (begin
                     (set! current-stmt (+ 2 current-stmt))
                     (eval-s environment))))
            ((equal? 'jump  (list-ref statement-seq current-stmt)) 
              (begin (jump-s environment)
                     (eval-s environment)))
            (else (error "Not a statement. -- STATE"))))
  
  (define (init-statement-seq stmt-seq)
    (map (lambda (sub-list) (map un-syntax sub-list))
         (map un-syntax stmt-seq)))
  
  (define (build-jump-table&stmt-seq seq-list jmp-tbl stmt-seq)
    (if (null? seq-list) 
        (begin (set! jump-table jmp-tbl)
               (set! statement-seq stmt-seq))
        (let* ((remain-sl (cdr seq-list))
               (label (caar seq-list))
               (sub-sl (cdar seq-list))
               (stmt-s2 (append stmt-seq sub-sl))
               (jt-counter (length stmt-seq))
               (jmp-tbl2 (append jmp-tbl (list (list label jt-counter)))))
          (build-jump-table&stmt-seq remain-sl jmp-tbl2 stmt-s2))))
  
  (cond ((or (null? exps) (not (eq? 2 (length exps))))
         (error "Two arguments expected. -- STATE" exps))
        (else
         'OK))
  (let ((arg1 (un-syntax (list-ref exps 0)))
        (arg2 (un-syntax (list-ref exps 1))))
    (cond ((not (list? arg1))
           (error "First argument is not a list. -- STATE" arg1))
          ((not (list? arg2))
           (error "Second argument is not a list. -- STATE" arg2))
          ((not (null? (filter
                        (lambda (elem) (not (list? elem)))
                        (map un-syntax arg1))))
           (error "First argument is not a list of lists. -- STATE"
                  (map un-syntax arg2)))
          ((odd? (length (un-parse-list arg2)))
           (error "Second argument is not a list of pairs. -- STATE"
                  (map un-syntax arg2)))
          (else
           'OK))
    (init-memory exps)
    (build-jump-table&stmt-seq (init-statement-seq arg1) (list) (list))
    (eval-s xenv)))