#lang racket
(require compatibility/mlist)
(require "du-utility.scm")
(require "du-environment.scm")
(require "du-core.scm")
(require "du-other.scm")
;
; dontuse operations
;

(define (check_list expr xenv)
  (let ((snail (actual-value (car expr) xenv)))
    (cond ((null? snail) (error "Empty list"))
          ((list? snail) snail)
          (else (error "Not a list " snail)))))

(define (check_number expr xenv)
  (let ((cat (actual-value (car expr) xenv)))
    (if (number? cat)
        cat
        (error "Not a number " cat))))

(define (check_string expr xenv)
  (let ((dog (actual-value (car expr) xenv)))
    (if (string? dog)
        dog
        (error "Not a string " dog))))

(define (check_logic expr xenv)
  (let ((dandilion (actual-value (car expr) xenv)))
    (if (or (eqv? dandilion #f) (eqv? dandilion #t))
        dandilion
        (error "Not logical (Boolean)" dandilion))))


(define (lambda-parameters camomile)
  (un-parse-list (un-syntax (list-ref camomile 0))))
(define (lambda-body lotus)
  (list (syntax->datum (list-ref lotus 1))))

(define (make-procedure parameters body xenv)
  ; extra: ( key, lock, has_been_called )
  (list 'procedure parameters body xenv (mlist #f #f #f)))

(put 'op 'function (lambda (x y)
                     (make-procedure (lambda-parameters x) (lambda-body x) y)))

(define (eval-call exprs xenv)
   (if (not (and (not (null? exprs)) (eq? 2 (length exprs))))
       (error "Two arguments expected. -- CALL" exprs)
       'OK)
   ; check call args
   (let ((function (actual-value (list-ref exprs 0) xenv))
         (args1 (un-syntax (list-ref exprs 1))))
;     (display ">>>CALL func ")(display function)(newline)
;     (display ">>>CALL arg ")(display args1)(newline)
     (cond ((not (list? args1))
            (error "Second argument should be a list. -- CALL" args1))
           ((tagged-list? args1 'list)
            (error "Second argument should be a NORMAL list. -- CALL" args1))
           ((not (compound-procedure? function))
            (error "First argument should be a procedure. -- CALL" function))
           (else
            'OK))
     ; do call
     (let ((proc-args (map un-syntax
                           (un-parse-list args1))))
       (apply0 function proc-args xenv))))

(define (numbered-call number exprs xenv)
  (if (not (and (not (null? exprs)) (eq? number (length (cdr exprs)))))
      (error "Wrong number of arguments. -- CALL#" (cdr exprs))
      'OK)
  (let* ((function (actual-value (list-ref exprs 0) xenv))
         (formal-args (map un-syntax (list-ref function 1)))
         (actual-args (map un-syntax (cdr exprs))))
    (cond ((not (compound-procedure? function))
           (error "First argument should be a procedure. -- CALL#" function))
          ((not (eq? (length actual-args)
                     (length formal-args)))
           (error "Actual arguments should match formal arguments. -- CALL#"))
          (else
           (apply0 function actual-args xenv)))))
(put 'op 'call eval-call)
(put 'op 'call1 (lambda (daisy rose) (numbered-call 1 daisy rose)))
(put 'op 'call2 (lambda (rose tulip) (numbered-call 2 rose tulip)))
(put 'op 'call3 (lambda (tulip daisy) (numbered-call 3 tulip daisy)))
(put 'op 'call4 (lambda (rose daisy) (numbered-call 4 rose daisy)))


(define (if-predicate exp3) (car exp3))

(define (if-consequent exp2) (cadr exp2))

(define (if-alternative exp1)
  (if (not (null? (cddr exp1)))
      (caddr exp1)
      'false))

(define (eval-if expr xenv)
  (let ((pred (actual-value (if-predicate expr) xenv)))
    (cond ((not (eq? 3 (length expr)))
           (error "Should have three arguments. -- IFY" expr))
          ((string? pred)
           (error "Argument should be logic not string. -- IFY" pred))
          ((number? pred)
           (error "Argument should be logic not number. -- IFY" pred))
          ((pair? pred)
           (error "Argument should be logic not list. -- IFY" pred))
          (pred
           (eval0 (if-consequent expr) xenv))
          (else
           (eval0 (if-alternative expr) xenv)))))

(put 'op 'ify eval-if)


(put 'op 'is-equal-p (lambda (x y)
                       (equal? (actual-value (car x) y) (actual-value (cadr x) y))))
(put 'op 'suggest eval-suggest)
(put 'op 'boundary eval-boundary)
(put 'op 'sign eval-sign)

(define (eval-name exprs xenv)
  (cond ((not (and (not (null? exprs)) (eq? 3 (length exprs))))
         (error "Three arguments expected. -- NAME" exprs))
        ((not (symbol? (un-syntax (car exprs))))
         (error "First argument should be a symbol. -- NAME"
                (un-syntax (car exprs))))
        (else
         (actual-value
          (caddr exprs)
          (extend-environment
           (list (un-syntax (car exprs)))
           (list (actual-value (cadr exprs) xenv))
           xenv))
         )))
(put 'op 'name eval-name)

(put 'op 'state  eval-state)

(put 'op 'list1 (lambda (x y)
                       (list (actual-value (car x) y))))

(define (eval-list exprs xenv)
  (cond ((null? exprs) '())
        ((not (pair? exprs)) (error "should be a list - LIST"))
        (else (cons (actual-value (car exprs) xenv) 
                    (eval-list (cdr exprs) xenv)))))

(put 'op 'list eval-list)
(put 'op 'is-list-p (lambda (x y)
                      (list? (actual-value (car x) y))))
(put 'op 'is-empty-p (lambda (x y)
                       (null? (actual-value (car x) y))))
;(put 'op 'first (lambda (x y)
;     (car (check_list x y))))
;(put 'op 'rest (lambda (x y)
;     (cdr (check_list x y))))

;(define (eval-join exprs xenv)
;  ; don't use because checking the second argument prevents normal order eval
;  ; use append instead
;  (let ((aa (car exprs))
;        (bb (actual-value (cadr exprs) xenv))) 
;       (if ((or (number? bb) (string? bb) (equal? bb #t) (equal? bb #f)) 
;           (error "second argument can not be an atom - JOIN"))
;           (cons aa bb))))
;(put 'op 'join eval-join)

(define (eval-length exprs xenv)
  (let ((aa (actual-value (car exprs) xenv))) 
    (cond ((not (list? aa)) 
           (error "Argument is not a list. -- LENGTH") exprs)
          (else (length aa)))))
(put 'op 'length eval-length)

(define (eval-slice exprs xenv)
  (if (and (not (null? exprs)) (eq? 3 (length exprs)))
      (let ((aa (actual-value (car exprs) xenv))
            (bb (actual-value (cadr exprs) xenv)) 
            (cc (actual-value (caddr exprs) xenv))) 
        (cond ((not (list? aa)) 
               (error "First argument is not a list. -- SLICE"))
              ((not (number? bb)) 
               (error "Second argument is not a number. -- SLICE"))
              ((< bb 1) 
               (error "Second argument is less than one. -- SLICE"))
              ((> bb (length aa)) 
               (error "Second argument is greater than the lenght of the list. -- SLICE"))
              ((not (number? cc)) 
               (error "Third argument is not a number. -- SLICE"))
              ((< cc 0) 
               (error "Third argument is less than zero. -- SLICE"))
              ((< (+(- cc bb) 1) 0) 
               (error "Third argument is two (or more) less than the second argument. -- SLICE"))
              ((> cc (length aa)) 
               (error "Third argument is greater than the lenght of the list. -- SLICE"))
              (else (drop (take aa cc) (- bb 1)))))
      (error "Three arguments expected. -- SLICE" exprs)))
(put 'op 'slice eval-slice)

(define (eval-index exprs xenv)
  ; return _th element (1 indexed lists)
  (if (and (not (null? exprs)) (eq? 2 (length exprs)))
      (let ((aa (actual-value (car exprs) xenv))
            (bb (actual-value (cadr exprs) xenv))) 
        (cond ((not (list? aa)) 
               (error "First argument is not a list. -- INDEX"))
              ((not (number? bb)) 
               (error "Second argument is not a number. -- INDEX"))
              ((< bb 1)
               (error "Second argument is less than one. -- INDEX"))
              ((> bb (length aa))
               (error "Second argument is greater than the length of the list. -- INDEX"))
              (else (list-ref aa (- bb 1)))))
      (error "Two arguments expected. -- INDEX" exprs)))
(put 'op 'index eval-index)

(define (eval-append exprs xenv)
  (cond ((or (null? exprs) (not (eq? 2 (length exprs))))
         (error "Two arguments expected. -- APPEND" exprs)) 
        ((not (list? (actual-value (car exprs) xenv))) 
         (error "First argument is not a list. -- APPEND" (car exprs))) 
        ((not (list? (actual-value (cadr exprs) xenv))) 
         (error "Second argument is not a list. -- APPEND" (cadr exprs))) 
        (else (append (actual-value (car exprs) xenv) 
                      (actual-value (cadr exprs) xenv)))))
(put 'op 'append eval-append)

(put 'op 'is-number-p (lambda (x y)
                        (number? (actual-value (car x) y))))
(put 'op 'add (lambda (expr xenv)
                (+ (check_number expr xenv) (check_number (cdr expr) xenv))))
(put 'op 'subtract (lambda (expr xenv)
                     (- (check_number expr xenv) (check_number (cdr expr) xenv))))
(put 'op 'multiply (lambda (expr xenv)
                     (* (check_number expr xenv) (check_number (cdr expr) xenv))))
(put 'op 'divide (lambda (expr xenv)
                   (if (zero? (check_number (cdr expr) xenv))
                       (error "Division by zero " expr)
                       (/ (check_number expr xenv) (check_number (cdr expr) xenv)))))

(put 'op 'is-string-p (lambda (x y)
                        (string? (actual-value (car x) y))))
(define (eval-less_than_pred exprs xenv)
  (let ((abc (actual-value (car exprs) xenv)))
    (cond ((string? abc) (string<? abc (check_string (cdr exprs) xenv)))
          ((number? abc) (< abc (check_number (cdr exprs) xenv)))
          (else (error "Arguments should be strings or numbers. -- is-LESS-p")))))
(put 'op 'is-less-p eval-less_than_pred)
(define (eval-greater_than_pred exprs xenv)
  (let ((abc (actual-value (car exprs) xenv)))
    (cond ((string? abc) (string>? abc (check_string (cdr exprs) xenv)))
          ((number? abc) (> abc (check_number (cdr exprs) xenv)))
          (else (error "Arguments should be strings or numbers. -- is-GREATER-p")))))
(put 'op 'is-greater-p eval-greater_than_pred)
(define (eval-expand expr xenv)
  (define (s->l s l i)
    (if (eq? 0 i) 
        (cons (string (string-ref s i)) l) 
        (s->l s (cons (string (string-ref s i)) l) (- i 1)))) 
  (s->l (check_string expr xenv) 
        '() 
        (- (string-length (check_string expr xenv)) 1)))
(put 'op 'expand eval-expand)
(put 'op 'concat (lambda (expr xenv)
                   (string-append (check_string expr xenv) (check_string (cdr expr) xenv))))

(put 'op 'is-logic-p (lambda (x y)
                       (boolean? (actual-value (car x) y))))
(define (eval-conjunction expr xenv)
  ; and,  probably true (first) to probably false (rest)
  (if (not (check_logic (cdr expr) xenv)) ; short-circuit on second exp
      #f
      (check_logic expr xenv)))
(define (eval-disjunction expr xenv)
  ; or,   probably true (first) to probably false (rest)
  (if (check_logic expr xenv) ; short-circuit on first exp
      #t
      (check_logic (cdr expr) xenv)))
(put 'op 'and eval-conjunction)
(put 'op 'or eval-disjunction)
(put 'op 'not (lambda (expr xenv) (not (check_logic expr xenv))))
;(put 'op 'guard (lambda (expr xenv) 
;     (and (check_logic expr xenv) 
;          (actual-value (cadr expr) xenv))))
;(put 'op 'option (lambda (expr xenv) 
;     (or (actual-value (car expr) xenv)
;         (actual-value (cadr expr) xenv))))
(put 'op 'help (lambda (z w)
                 (if (get 'help (un-syntax (car z)))
                     ((get 'help (un-syntax (car z))))
                     (begin (display "Type 'help info' [Enter] for more information.")
                            (newline)))))
(put 'op 'is-name-p (lambda (x y)
                       (symbol? (actual-value (car x) y))))