;;; Standard lib, in scheme

; TODO: Fix below
(define eq? eqv?)
(define equal? eqv?)
(define (error str)
  (begin (display "SCHEME ERROR: ")
         (display str)
         (display "\n")))

; Lists

(define (foldl f i l)
  (if (null? l)
      i
      (foldl f (f (car l) i) (cdr l))))

(define (foldr f i l)
  (if (null? l)
      i
      (f (car l) (foldr f i (cdr l)))))


(define (map f l)
  (if (null? l)
      '()
      (foldr (lambda (e a) (cons (f e) a)) '() l)))

(define (length l)
  (foldl + 0 (map (lambda (x) 1) l)))

(define (reverse l)
  (foldl cons '() l))

(define (append l1 l2)
  (foldr cons l2 l1))


(define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html
       (lambda (x k)
         (if (zero? k)
             x
             (list-tail (cdr x) (- k 1)))))

(define generic-member
  (lambda (compare obj ls)
    (if (null? ls)
      #f
      (if (compare obj (car ls))
          ls
          (generic-member compare obj (cdr ls))))))

(define (memq   obj ls) (generic-member eq?    obj ls))
(define (memv   obj ls) (generic-member eqv?   obj ls))
(define (member obj ls) (generic-member equal? obj ls))

(define (cond-helper vo)

    ; Base case:
    (if (null? vo)
        '(if #f '())  ; This trick is used to ensure the result is identical to
                      ; failing a one-armed if-statement.

    ; Error: incorrect format
    (if (not (pair? vo))
        (error "cond: Incorrect format")

    ; Else statement
    (if (equal? 'else (caar vo))
        (car (cdr (car vo)))

    ; Normal statement
    `(if ,(caar vo)
         (begin ,@(cdr (car vo)))
         ,(cond-helper (cdr vo)))

    ))))

(define-syntax cond
  (lambda (vo)
    (if (not (equal? 'cond (car vo)))
        (error "cond: Expected cond as keyword")

    (if (null? (cdr vo))
        (error "cond: cond must not be empty")

    (cond-helper (cdr vo))))))

(define (generic-assoc compare key als)
  (cond
    ; Error check on `compare` and `key`
    ( (not (procedure? compare))
      (error "generic-assoc: Argument #1 expected to be procedure, but was not.") )
    ( (not (symbol? key))
      (error "generic-assoc: Argument #2 expected to be symbol, but was not.") )

    ; Base case
    ( (null? als)
      #f )

    ; Error check `als` structure
    ( (if (not (pair? (car als))) #t (not (symbol? (caar als))))
      (error (string-append "generic-assoc: Argument #3 should be associative list, but was not"
                            ""
                            (datum->string als))))

    ; Found the correct one
    ( (compare key (caar als))
      (cdr (car als)) )

    ; Otherwise: Continue along in the assoc list
    ( else
      (generic-assoc compare key (cdr als)))

    ))

(define (assq  obj ls) (generic-assoc eq?    obj ls))
(define (assv  obj ls) (generic-assoc eqv?   obj ls))
(define (assoc obj ls) (generic-assoc equal? obj ls))



; Math

(define (= a b)
  (if (<= a b)
      (>= a b)
      #f))

(define (zero?     x) (= x 0))
(define (positive? x) (> x 0))
(define (negative? x) (< x 0))
(define (odd?      x) (= (mod x 2) 1))
(define (even?     x) (= (mod x 2) 0))

;;;;;;;; Testing stuff ;;;;;;;;;;


; Test some compilation stuff

(define f (lambda (x) ((lambda (y) (+ y 2)) (car x))))

(define g (lambda (x) (if ((lambda (y) (= y 2)) (car x))
                          y
                          'fuck)))

(define fac_fucked
  ( (lambda (f) (lambda (v) (f f v)))
    (lambda (f v)
      (if (= v 0)
          1
          (* v (f f (+ v -1)))))))

(display "Recursive combinator used on factorial.\n\tExpect: 120\n\tGotten: ")
(display (fac_fucked 5))
(newline)

; Test that function arguments are in correct order

(define (test-arg-order a b c)
  (begin (display a)
         (display " ")
         (display b)
         (display " ")
         (display c)
         (newline)))

(display "Testing that argument order is correct:\n\tExpect: 1 2 3\n\tGotten: ")
(test-arg-order 1 2 3)
(display "\n")

; Test string

(display "Hello World") (newline)

; Test functions

(define add-three (lambda (x y z) (+ (+ x z) y)))

; Test factorial

(define fac  (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1)))

(define (faca x a)
                (if (>= x 1)
                   (faca (+ x -1) (* x a))
                   a))

(define x 5)
(display x)          (newline)
(display (fac x))    (newline)
(display (faca x 1)) (newline)

; Test stuff?

(define (f . l) (cdr l))
(define y '(1 2 3))

(display y)          (newline)
(display (car y))    (newline)
(display (cdr y))    (newline)

(display (append '(1 2 3) '(4 5 6)))    (newline)

; Test system

(define (concat-string s sep)
  (foldr (lambda (e a) (string-append (datum->string e) sep a))
         ""
         s))

(define test
  (lambda (name tests)
    (begin (display name)
           (display "\n\tExpect: ")
           (display (concat-string (map car tests) "  "))
           (display "\n\tGotten: ")
           (display (concat-string (map cdr tests) "  "))
           (newline))))

(define (header name) (display (string-append "\n * " name " *\n")))

(header "R5RS: Test equivalence")

(define (list-tail ls index)
  (if (zero? index)
      ls
      (list-tail (cdr ls) (+ index -1))))

(define (list-ref ls index)
  (car (list-tail ls index)))

; Actual Tests

(display "\n* R5RS: Quotation and quasi-quotation *\n")

(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) (quote (1 2 3)))
(display (x))
(newline)

(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) '(1 2 3))
(display (x))
(newline)

(display "Testing quasi-notation basics!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) `(1 2 3))
(display (x))
(newline)

(display "Testing quasi-notation!\n\tExpect: (1 a 2 a 3 a 4)\n\tGotten: ")
(define (x p) `(1 ,p 2 ,p 3 ,p 4))
(display (x 'a))
(newline)

(display "Testing quasi-notation advanced!\n\tExpect: (1 2 3 4 5)\n\tGotten: ")
(define (x p) `(1 ,@p 3))
(display (x '(2 3 4)))
(newline)

(display "Testing quasi-notation advanced!\n\tExpect: (1 `(,a ,x 3) 4 5)\n\tGotten: ")
(define (f x y) `(,x `(,a ,x 3) 4 ,y))
(display (f 1 5))
(newline)

(display "Testing quasi-notation advanced!\n\tExpect: ((1 2) . 3)\n\tGotten: ")
(define (f) (cons `(1 2) 3))
(display (f))
(newline)

; Check set!

(set! x 10)
(display x) (newline)

(newline)
(display "* R5RS: Testing booleans *")
(newline)

(define fun-test
  (lambda (name f cases)
    (test (string-append "Testing function " name "")
          (map (lambda (a) (cons (car a) (f (cdr a))))
               cases))))

(fun-test "not" not
          '( (#f . #t)
             (#t . #f)
             (#f . "hi")
             (#f . 7)
             (#f . a)
             (#f . ())
             ))

(fun-test "boolean?" boolean?
          '( (#t . #t)
             (#t . #f)
             (#f . "hi")
             (#f . 7)
             (#f . a)
             (#f . ())
             ))

(header "R5RS: Testing numerical operators")

(fun-test "number?" number?
          '( (#f . #t)
             (#f . #f)
             (#f . "hi")
             (#t . 7)
             (#t . 5232)
             (#f . a)
             (#f . ())
             ))

(header "R5RS: Testing fold and map")

(display "Testing sum over foldl!\n\tExpect: 28\n\tGotten: ")
(display (foldl + 0 '(1 2 3 4 5 6 7)))
(newline)

(display "Testing sum over foldr!\n\tExpect: 28\n\tGotten: ")
(display (foldr + 0 '(1 2 3 4 5 6 7)))
(newline)

(display "Testing map!\n\tExpect: (21 22 23)\n\tGotten: ")
(display (map (lambda (a) (+ 20 a)) '(1 2 3)))
(newline)

(display "Testing length!\n\tExpect: 13\n\tGotten: ")
(display (length '(1 2 3 1 2 3 1 2 3 1 2 3 1)))
(newline)

(display "Testing length!\n\tExpect: (5 4 3 2 1)\n\tGotten: ")
(display (reverse '(1 2 3 4 5)))
(newline)

(newline)
(display "* R5RS: Test string *")
(newline)

(display "Testing string-concat\n\tExpect: Hello World\n\tGotten: ")
(display (string-append "Hello" " " "World"))
(newline)

(define do-stuffer
  (lambda (name_i arg1_i arg2_i)
    (lambda (x)
      (cons (list-ref x name_i)
            (eqv? (list-ref x arg1_i)
                  (list-ref x arg2_i))))))

(define eqv-test
  (lambda (name tests)
    (test name (append (map (do-stuffer 0 1 2) tests)
                       (map (do-stuffer 0 2 1) tests)
                       ))))

(eqv-test "eqv? booleans"
      '(
        (#t  #t #t)
        (#t  #f #f)
        (#f  #t #f)
        (#f  #f #t)
       ))

(eqv-test "eqv? inter-types"
      '(
        (#f    2    a)
        (#f    4    "Test")
        (#f    ()   (a b))
        (#f    9    ())
       ))

(eqv-test "eqv? symbols"
      '(
        (#t  hello hello)
        (#t  World wOrld)
        (#f  hello world)
        (#f  hello World)
       ))


(header "R5RS: Test if-expressions")

(test "If expressions exp!"
      `(
        (6 . ,(* 3 (if #t 2 0)))
        (0 . ,(* 3 (if #f 2 0)))
        ("Hello World" . ,(if #t "Hello World"))
        ("???" . ,(if #f "Hello World"))
      ))

(header "R5RS: Testing Eval system")

(display "Eval expression. Expect 6: ")
(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5)))
(newline)

(newline)
(display "* R5RS: Testing Macro system *")
(newline)

; Test define-syntax

(display "Test define-syntax:\n    Expect: 4 ()\n    Gotten: ")

(define-syntax const
  (lambda (so)
    `(lambda () ,(car (cdr so)))))

(define x (const 4))
(display (x))
(display " ")
(define x (const '()))
(display (x))
(display "\n")

(display "Test defining let using macroes:\n    Expect: 23 82 105\n    Gotten: ")

(define (let-names-helper vo)
  (cond ( (not (pair? vo))
          (error "let: incorrect form: Not a pair!"))
        ( (not (symbol? (car vo)))
          (error "let: incorrect form: Not a symbol!"))
        ( else
          (car vo))))

(define-syntax let
  (lambda (vo)
    (cond ( (not (equal? 'let (car vo)))
            (error "let: Incorrect form: Let was not the first keyword!"))

          ( else
            `( (lambda ,(map let-names-helper (cadr vo)) ,(caddr vo))
               ,@(map cadr (cadr vo)))))))

(let ((a 23)
      (b 82))
  (begin (display a)
         (display " ")
         (display b)
         (display " ")
         (display (+ a b))))

(display "\n* R5RS: Lexical conventions *\n")

(define a-variable 20)
(if #f (begin
  (display "Test case-insensitivity (required by R5RS)\n\tExpect: 20 20 20 20\n\tGotten: ")
  (display a-variable) (display " ")
  (display A-variable) (display " ")
  (display a-VARiable) (display " ")
  (display A-VARIABLE))
    (display "Skipped test!\n"))

; Test environment set

(newline)
(display "* Testing custom library *")
(newline)

(display "Testing set-env! Expect 32: ")
(display ((set-env! (lambda () x) '((x . 32)) )))
(newline)

(display "Testing string->datum! Expect (2): ")
(display (cdr (string->datum "(display 2)")))
(newline)

; Test syntax-rules

(header "Testing syntax-rules (move to macro once implemented)")

(define (syntax-rules-dots-traversal fn ls)
  (if (null? ls)
      '()
  (if (not (pair? ls))
      #f
  (if (fn (car ls))
      (let ((found (syntax-rules-dots-traversal fn (cdr ls))))
        (if found
            `( ,(cons (car ls) (car found))
               ,(cdr found) )))



  `(() ,ls) ))))

(define construct-pattern-predicate
  (lambda (name pat literals)
    (if (number? pat)
        `(equal? ,name ,pat)

    ; Is symbol
    (if (symbol? pat)
        (if (member pat literals)
            ; Is literal
            `(equal? ,name ',pat)

            ; Or is variable binding
            #t)

    (if (null? pat)
        `(null? ,name)

    (if (if (pair? pat) (if (pair? (cdr pat)) (equal? '... (cadr pat))
                            #f) #f)
        (let ((predicate (construct-pattern-predicate
                                         'vo3
                                         (car pat)
                                         literals)))
          (cond ; Very simple pattern
                ( (if (equal? #t predicate) (null? (cddr pat)) #f)
                  #t )

                ; Somewhat simple predicate
                ( (equal? #t predicate)
                  (construct-pattern-predicate ''()
                                                (cddr pat)
                                                literals)

                ; Complex predicate / Default
                ( else
                  `(let ((after (syntax-rules-dots-traversal
                                  (lambda (vo3) ,predicate)
                                  ,name)))
                     (if after
                         ,(construct-pattern-predicate '(cdr after)
                                                        (cddr pat)
                                                        literals)
                         #f))))))

    (if (pair? pat)
        (let (( test
                 (construct-pattern-predicate `(car ,name)
                                               (car pat)
                                               literals))
              ( body
                 (construct-pattern-predicate `(cdr ,name)
                                               (cdr pat)
                                               literals)))
          (cond ( (if (equal? #t test) (equal? #t body) #f)
                   `(pair? ,name))
                ( (equal? #t test)
                   `(if (pair? ,name) ,body #f))
                ( (equal? #t body)
                   `(if (pair? ,name) ,test #f))
                ( else
                   `(if (pair? ,name) (if ,test ,body #f) #f))
                ))

    'fuck )))))))

(define (find-variable-bindings literals path pattern)
    ; Is symbol
    (if (if (symbol? pattern) (not (member pattern literals)) #f)
        `((,pattern ,path))


    ; Is dots pair
    ; TODO: Fix below, it is fucked.
    (if (if (pair? pattern)
            (if (pair? (cdr pattern))
                (equal? '... (cadr pattern)) #f) #f)
        (let ( ( predicate
                 (construct-pattern-predicate
                                  'vo3
                                  (car pattern)
                                  literals)))
          (if (equal? predicate '#t)
              `((,(car pattern)  ,path))
              (error "Not implemented")))

        ;`(let ((found (syntax-rules-dots-traversal
                        ;(lambda (vo3) ,predicate)
                        ;,pattern)))
           ;(append
             ;'((,(car pattern) ,path))
             ;,(find-variable-bindings literals
                                      ;`(list-ref ,path (length found))
                                      ;(cddr pattern))))
    ; Is pair

    (if (pair? pattern)
        (append (find-variable-bindings literals `(car ,path) (car pattern))
                (find-variable-bindings literals `(cdr ,path) (cdr pattern)))

    ; Is anything else
    ; TODO: Vector patterns

    '() ))))

(define (construct-result bindings template)
    ; Is symbol
    (if (if (symbol? template) (assoc template bindings) #f)
        (cons 'unquote (cons template '()))

    ; Is dots pair

    (if (if (pair? template)
            (if (pair? (cdr template))
                (equal? '... (cadr template)) #f) #f)
        (cons (cons 'unquote-splicing (cons (car template) '()))
              (construct-result bindings (cddr template)))

    ; Is normal pair

    (if (pair? template)
        (cons (construct-result bindings (car template))
              (construct-result bindings (cdr template)))

    ; Is anything else
    ; TODO: Vector patterns

    template ))))

(define syntax-rules-rec
  (lambda (macro-name var-name literals rules)
    (if (null? rules)
        '''doublefuck
        (let ((pattern  (caar rules))
              (result   (cadar rules))
              (bindings (find-variable-bindings literals var-name (caar rules)))
             )
          (begin (display "Test ")
                 (display bindings)
                 (newline)

          (if (eqv? macro-name (car pattern))
              `(if ,(construct-pattern-predicate var-name
                                                 pattern
                                                 literals )
                   (let ,bindings
                     ,(cons 'quasiquote (cons (construct-result bindings result) '()))
                     )
                   ,(syntax-rules-rec macro-name var-name literals (cdr rules)))

              (begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
                     (display "\n\tFirst had ")
                     (display macro-name)
                     (display "\n\tBut one of them had ")
                     (display (car pattern))
                     (newline)))))))
)


(define-syntax syntax-rules
  (lambda (vo)
    (let ((literals  (cons (car (caaddr vo)) (cadr vo)))
          (rules     (cddr vo))
          (name      (car (caaddr vo))))

      `(lambda (vo2)
         ,( syntax-rules-rec name 'vo2 literals rules ))
      )))

; Define true

(define-syntax true
 (syntax-rules ()
    ((true) #t)))

(test "Attempting to define true using syntax rules."
      `(
        ( #t . ,(true))
        ( #f . ,(not (true)))
       ))

;


; Below should produce an error:
;(define-syntax bad-rule
 ;(syntax-rules ()
    ;((bad-rule-1) #t)
    ;((bad-rule-2) #f)))

(define-syntax bool
 (syntax-rules ()
    ((bool) #t)
    ((bool 0) #f)
    ((bool 1) #t)
    ))

(test "Attempting to define bool ? using syntax rules."
      `(
        ( #t . ,(bool))
        ( #f . ,(bool 0))
        ( #t . ,(bool 1))
       ))

(define-syntax fun_macro
 (syntax-rules (two)
    ((fun_macro) 1)
    ((fun_macro two) (+ (derp) (derp)))
    ))

(test "Defining weird macroes using syntax-rules."
      `(
        ( 1 . ,(fun_macro))
        ( 2 . ,(fun_macro two))
       ))

(define-syntax +1
  (syntax-rules ()
    ((+1 n) (+ 1 n))))

(test "Defining +1 using syntax-rules."
      `(
        ( 6 . ,(+1 5))
        ( 1 . ,(+1 0))
        ( 0 . ,(+1 -1))
       ))

(define-syntax fun_macro
  (syntax-rules ()
    ((fun_macro a)  a)
    ((fun_macro a b ...) (+ a (derp b ...)))
))

(test "Defining list using syntax-rules."
      `(
        ( 1 . ,(fun_macro 1))
        ( 6 . ,(fun_macro 6))
        ( 9 . ,(fun_macro 4 5))
        ( 3 . ,(fun_macro 1 1 1))
       ))

(exit)


;;;;; ;

(exit)

(define-syntax and
 (syntax-rules ()
    ((and) #t)
    ((and test) test)
    ((and test1 test2 ...)
     (if test1 (and test2 ...) #f))))

(test "Attempting to define and using syntax rules."
      `(
        (#t . ,(and))
        (#f . ,(and #f))
        (#t . ,(and #t))
        (#f . ,(and #f #f))
        (#f . ,(and #t #f))
        (#f . ,(and #f #t))
        (#t . ,(and #t #t))
        (#f . ,(and #t #f #t))
        (#f . ,(and #f #f #f))
        (#t . ,(and #t #t #t))
        (#f . ,(and #f #t #f #f #f #f))
        (#t . ,(and #t #t #t #t #t #t))
       ))

; TODO: Use syntax-rules to implement let and or.

(display "")