tiger-scheme/example.scm

;;; Standard lib, in scheme

; 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)))))



; Math

(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))


; 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)

(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)

; Check set!

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

(newline)
(display "* R5RS: Testing numerical operators *")
(newline)

(display "Testing number?\n\tExpect: #t #f #f #f\n\tGotten: ")
(display (number? 5))
(display " ")
(display (number? #f))
(display " ")
(display (number? "hello"))
(display " ")
(display (number? '(1 2)))
(newline)

(newline)
(display "* R5RS: Testing fold and map *")
(newline)

(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 if-expressions*")
(newline)

(display "If-then exp!\n\tExpect: 6\n\tGotten: ")
(display (* 3 (if #t 2 0)))
(newline)

(display "If-else exp!\n\tExpect: 0\n\tGotten: ")
(display (* 3 (if #f 2 0)))
(newline)

(display "If-one-branch exp!\n\tExpect: Hello World\n\tGotten: ")
(if #t (display "Hello World\n"))

(display "If-one-branch exp!\n\tExpect: \n\tGotten: ")
(if #f (display "Hello World\n"))

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

(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 "\n* R5RS: Lexical convention *\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

(newline)
(display "* Testing syntax-rules (move to macro once implemented) *")
(newline)

(display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ")

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

(display (and #t #t)) (display " ")
(display (and #f #t)) (display " ")
(display (and #f #f)) (display " ")
(display (and #t #f)) (newline)

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

(display "")