(Racket) tLISP

 

#lang racket
(define (tokenize s)
  (let loop ([i 0]
             [tok ""]
             [result '()])
    (if (< i (string-length s))
        (let ([c (substring s i (+ 1 i))])
          (cond [(regexp-match #rx"[ \t\r\n]" c)
                 (loop (+ 1 i) "" (append result 
                                          (if (> (string-length tok) 0)
                                              (list tok)
                                              '())))]
                [(regexp-match #rx"[()]" c)
                 (loop (+ 1 i) "" 
                       (if (> (string-length tok) 0)
                           (append result (list tok c))
                           (append result (list c))))]
                [else
                 (loop (+ 1 i) (string-append tok c) result)]))
        (if (> (string-length tok) 0)
            (append result (list tok))
            result))))

(define-syntax-rule (++ x)
  (set! x (+ 1 x)))

(define (process-tokens lst)
  (define pos 0)
  (define (proc accum)
    ;(displayln (list "pos" pos))
    (if (< pos (length lst))
        (begin
          (let ([t (list-ref lst pos)])
            (++ pos) 
            (cond [(string=? t "(") (proc (append accum (list (proc '()))))]
                  [(string=? t ")") accum]
                  [else (proc (append accum (list t)))]))
          )
        (first accum)))
  (proc '()))

(define (t-eval e env)  
  (cond [(and (string? e) (regexp-match #px"[[:digit:]]+" e)) e] ; number        
        [(and (string? e) (regexp-match #px"[[:alpha:]]+" e)) (second (assoc e env))] ; symbol
        [(and (list? e) (string? (first e)) (regexp-match #px"fn" (first e))) (list e env)] ; fn = function * env
        [(and (list? e) (string? (first e)) (regexp-match #px"cat1" (first e))) (string-append (t-eval (second e) env) "1")] ; cat1
        [else (t-apply (t-eval (first e) env) (t-eval (second e) env))] ; function application
        ))

(define (evaluate e)
  ;(t-eval e '(("inc" add1)))
  (t-eval e '())
  )

(define (t-apply f x)
  (let* ([fdef (first f)]
         [body (first (drop fdef 2))]
         [env (second f)]
         [arg (first (second fdef))])
    (t-eval body (append env (list (list arg x))))))

(define (parse-list s)
  (let ([tokens (tokenize s)])
    (process-tokens tokens)))

(define (main)
  (define tests '("1"
                  "((fn (x) x) (fn (x) x))"
                  "((fn (x) x) 1)"
                  "(cat1 (cat1 34))"))
  (for ([test tests])
    (displayln test)
    (displayln "* Tokens:")
    (for ([x (tokenize test)]) (displayln x))  
    (define r (parse-list test))
    (displayln "* Parsed:")
    (displayln r)
    ;(displayln "* Items:")
    ;(for ([x r]) (displayln x))
    (displayln "* Evaluated:")
    (displayln (evaluate r))
    (displayln "---")))

(main)