ICFP 2014 Programming Contest Non-entry

README

C 2014 Jesse Millikan except for files provided by contest.

gcc-assembler.rkt translates from labeled to adressed assembly in S-expression format, and provides printing GCC S-expression format to GCC.
gcc-lisp.rkt compiles a small scheme-like language to labeled assembly.
main.rkt contains some testable samples and simple working LambdaMan AIs.

In main.rkt,
(compile-and-print follow-timed-switch) 
to get a LambdaMan that will actually move about the maze a little.

gcc-asm.rkt

#lang racket

(provide assemble assembly->gcc)

;; Labeled ASM -> ASM
(define (assemble prog)
  (replace-labels (remove-labels prog) (gather-labels prog)))

;; Labeled ASM -> Hash of symbol to address (integer)
(define (gather-labels prog)
  (define (g prog labels n)
    (if (null? prog) labels
        (let ((ins (first prog)))
          (let ((new-labels
                 (if (pair? (first ins))
                     (hash-set labels (first (first ins)) n)
                     labels)))
            (g (rest prog) new-labels (+ n 1))))))
  (g prog (hasheq) 0))

;; Unlabeled ASM * Hash of symbol to address -> ASM
(define (replace-labels prog labels)
 (map 
  (lambda (ins)
         (cons (first ins)
               (map 
                (lambda (arg) 
                  (if (symbol? arg)
                      (hash-ref labels arg)
                      arg))
                (rest ins))))
  prog))

;; Labeled ASM -> Unlabeled ASM
(define (remove-labels prog)
  (map (lambda (ins)
         (if (pair? (first ins))
             (rest ins)
             ins))
       prog))

;; ASM -> GCC string
(define (assembly->gcc prog)
  (apply string-append (map instruction->string prog)))

(define (instruction->string ins)
  (string-append (string-upcase (symbol->string (first ins)))
                 (apply string-append (map (lambda (x) (string-append " " (number->string x))) (rest ins)))
                 "\n"))
  

(module+ test 
         (require rackunit)
         (check-equal? (assemble '()) '())
         (check-equal? (assemble '((ADD))) '((ADD)))
         (check-equal? (assemble '(((a) ADD))) '((ADD)))
         (check-equal? (assemble '(((a) LDF b)
                                ((b) LDF a)))
                    '((LDF 1)
                      (LDF 0)))
         (check-equal? (assemble GOTO-LABELED-ASM) GOTO-ASM)
         (check-equal? (assembly->gcc '((ADD))) "ADD\n")
         (check-equal? (assembly->gcc '((LDF 1)
                                        (LDF 0)))
                       "LDF 1\nLDF 0\n")
)

(define down-ai 
  '((DUM  2)
    (LDC  2)
    (LDF  step)
    (LDF  init)
    (RAP  2)
    (RTN)
    ((init) LDC  42)
    (LD   0 1)
    (CONS)
    (RTN)
    ((step) LD   0 0)
    (LDC  1)
    (ADD)
    (LD   1 0)
    (CONS)
    (RTN)))

(define GOTO-ASM
  '((DUM  2)        
    (LDF  16)       
    (LDF  10)       
    (LDF  6)        
    (RAP  2)        
    (RTN)           
    (LDC  1)
    (LD   0 0)      
    (AP   1)        
    (RTN)
    (LD   0 0)      
    (LDC  1)
    (SUB)
    (LD   1 0)      
    (AP   1)        
    (RTN)
    (LD   0 0)      
    (LDC  1)
    (ADD)
    (LD   1 1)      
    (AP   1)        
    (RTN)))

(define GOTO-LABELED-ASM
  '(
    (DUM  2)        
    (LDF  go)       
    (LDF  to)       
    (LDF  main)     
    (RAP  2)        
    (RTN)           
    ((main) LDC  1)
    (LD   0 0)      
    (AP   1)        
    (RTN)
    ((to) LD   0 0)      
    (LDC  1)
    (SUB)
    (LD   1 0)      
    (AP   1)        
    (RTN)
    ((go) LD   0 0)      
    (LDC  1)
    (ADD)
    (LD   1 1)      
    (AP   1)        
    (RTN)))

gcc-lisp.rkt

#lang racket

(require racket/match)

(provide compile BUILTIN-LIB EMPTY-LIB)

;; Lisp -> Labeled ASM
(define (compile prog library)
  ;; Collect function names and establish an ordering...
  (let ((fnames (append (collect-names prog) (library-fnames library))))
    (let ((funs-asm (compile-funs prog fnames)))
      `((DUM ,(length fnames))
        ,@(map
           (lambda (fname) `(LDF ,fname)) fnames)
        (LDF -entry-)
        (RAP ,(length fnames))
        (RTN)
        ((-entry-) LDF main)
        (AP 0)
        (RTN)
        ,@funs-asm
        ,@(library-bodies library)))))

(define (collect-names prog)
  (map 
   (lambda (fundef)
     (first (second fundef)))
   prog))

(define (compile-funs prog fnames)
  (apply append (map (lambda (f) (compile-fun f fnames)) prog)))

(define (compile-fun fundef fnames)
  (match fundef
    [`(define (,fname ,args ...) ,body)
     (let ((compiled-body (compile-expr body (list args fnames))))
       (label-function fname
                       `(,@(sect-body compiled-body)
                         (RTN)
                         ,@(sect-rest compiled-body))))]))

(define (label-function fname asm)
  `(((,fname) ,@(first asm))
    ,@(rest asm)))

(define -number- 0)
(define (numbered s)
  (let ((numbered-sym 
         (string->symbol
          (string-append
           (symbol->string s) (number->string -number-)))))
    (set! -number- (+ 1 -number-))
    numbered-sym))

;; Labeled ASM * Labeled ASM
(struct sect (body rest))

;; Expr -> Sect
(define (compile-expr expr env)
  (cond
   [(number? expr) (sect `((LDC ,expr)) '())]
   [(symbol? expr) (sect `((LD ,@(lexical-address expr env))) '())]
   ;; TODO: Special forms

   [(and (list? expr) (equal? 'if (first expr)))
    (let ((cond-expr (second expr)) (true-case (third expr)) (false-case (fourth expr))
          (t-label (numbered '-if-t-)) (f-label (numbered '-if-f-)))
      (let ((compiled-cond (compile-expr cond-expr env))
            (compiled-t (compile-expr true-case env))
            (compiled-f (compile-expr false-case env)))
        (sect `(,@(sect-body compiled-cond)
                (SEL ,t-label ,f-label))
              (append (label-function t-label (sect-body compiled-t))
                      '((JOIN))
                      (label-function f-label  (sect-body compiled-f))
                      '((JOIN))
                      (sect-rest compiled-cond)
                      (sect-rest compiled-t)
                      (sect-rest compiled-f)))))]

   [(list? expr)
    ;; Cannot eval expressions to function position at the moment.
    ;; (Or rather, we don't have values "tagged" to do so.)
    (let ((compiled-arg-sects (map (lambda (e) (compile-expr e env)) (rest expr)))
          (compiled-fn (compile-expr (first expr) env)))
      (sect
       (append
     ;; Hope this argument order is right.
        (apply append (map sect-body compiled-arg-sects)) 
        `(,@(sect-body compiled-fn)
          (AP ,(length (rest expr)))))
       (apply append
              (map sect-rest (cons compiled-fn compiled-arg-sects)))))]
   [#t (error "Unhandled")]))

(define (lexical-address expr env)
  (define (la env env-branch env-depth branch-depth)
    (if (null? env-branch)
        (begin
          (when (null? env) (error "Symbol not found"))
          (la (rest env) (first env) (+ 1 env-depth) 0))
        (if (equal? (first env-branch) expr)
            (list env-depth branch-depth)
            (la env (rest env-branch) env-depth (+ 1 branch-depth)))))
  (la (rest env) (first env) 0 0))

;; A list of builtin functions - (name asm)

(define (builtin-2 s ins)
  `(,s (((,s) LD 0 0) (LD 0 1) (,ins) (RTN))))

(define (builtin-1 s ins)
  `(,s (((,s) LD 0 0) (,ins) (RTN))))

(define builtins
  `(,(builtin-2 '+ 'ADD)
    ,(builtin-2 '* 'MUL)
    ,(builtin-2 '- 'SUB)
    ,(builtin-2 '% 'DIV)
    ,(builtin-2 'cons 'CONS)
    ,(builtin-2 '> 'CGT)
    ,(builtin-2 '>= 'CGTE)
    ,(builtin-2 '= 'CEQ)
    ,(builtin-1 'atom? 'ATOM)
    ,(builtin-1 'car 'CAR)
    ,(builtin-1 'cdr 'CDR)))

(struct library (fnames bodies))

(define BUILTIN-LIB (library (map first builtins) (apply append (map second builtins))))
(define EMPTY-LIB (library '() '()))

(module+ test
         (require rackunit)
#|
Empty prog is broken, don't feel like rewriting
         (check-equal? 
          (compile EMPTY-PROG EMPTY-LIB) 
          EMPTY-ASM)
|#
         (check-equal?
          (compile-fun '(define (second-arg a b) b) '(main second-arg))
          '(((second-arg) LD 0 1) (RTN)))

         (check-equal?
          (compile-fun '(define (get-main a b) get-main) '(main get-main))
          '(((get-main) LD 1 1) (RTN)))

         (check-equal?
          (compile-fun '(define (call-g a b) (g b 5)) '(main call-g g))
          '(((call-g) LD 0 1) (LDC 5) (LD 1 2) (AP 2) (RTN)))

         (check-equal? 
          (compile-fun '(define (f a b) (g 5 (h a b))) '(main f g h))
          '(((f) LDC 5) (LD 0 0) (LD 0 1) (LD 1 3) (AP 2) (LD 1 2) (AP 2) (RTN)))

         ;; Hand check that this just has different gensyms
         (check-equal?
          (compile-fun '(define (f) (if 0 1 2)) '(main f))
          '(((f) LDC 0) (RTN) ((-if-t-x) LDC 1) (JOIN) ((-if-f-y) LDC 2) (JOIN)))

)

(define EMPTY-PROG
  '((define (main) 0)))

(define EMPTY-ASM
  '((DUM 1)
    (LDF main)
    (LDF main)
    (RAP 1)
    (RTN)
    ((main) LDC 0)
    (RTN)))

goto.gcc

  DUM  2        ; 2 top-level declarations
  LDF  16       ; declare function go
  LDF  10       ; declare function to
  LDF  6        ; main function
  RAP  2        ; load declarations into environment and run main
  RTN           ; final return
  LDC  1
  LD   0 0      ; var go
  AP   1        ; call go(1)
  RTN
  LD   0 0      ; var n
  LDC  1
  SUB
  LD   1 0      ; var go  <-- HERE
  AP   1        ; call go(n-1)
  RTN
  LD   0 0      ; var n
  LDC  1
  ADD
  LD   1 1      ; var to <-- AND HERE
  AP   1        ; call to(n+1)
  RTN

local.gcc

LDC  21
LDF  4    ; load body
AP   1    ; call body with 1 variable in a new frame
RTN
LD   0 0  ; var x    :body
LD   0 0  ; var x
ADD
RTN

main.rkt

#lang racket

(require "gcc-asm.rkt"
         "gcc-lisp.rkt")

(define (compile-and-print prog)
  (display (assembly->gcc (assemble (compile prog BUILTIN-LIB)))))

(define test-add 
  '((define (main)
      (+ 1 2))))

(define test-cons
  '((define (main)
      (cons 1 (cons 2 (cons 3 0))))))

(define test-defs
  '((define (main)
      (f (g 5)))
    (define (f x) (+ x 1))
    (define (g x) (* x 3))))

(define test-reenter
  '((define (main) (f 5))
    (define (f x) (g (+ x 1)))
    (define (g x) (* x 3))))

(define test-sub
  '((define (main) (- 10 2))))

(define test-if
  `((define (main) 
      (if (f 0) (f 10) (f 25)))
    (define (f x)
      (+ x 1))))

(define test-item-at
  `((define (main)
      (item-at (test-list) 1))
    (define (item-at-pos pos map)
      (item-at 
       (item-at map (cdr pos))
       (car pos)))
    (define (test-list)
      (cons 15 (cons 16 (cons 17 0))))
    (define (item-at lst index)
      (if (= 0 index) (car lst)
          (item-at (cdr lst) (- index 1))))
))

;; Expect 7...
(define test-conds
  `((define (main)
      (+ 
       (if (> 2 1) 1 0)
       (+
        (if (>= 2 2) 2 0)
        (+
         (if (= 2 2) 4 0)
         (+ 
          (if (> 1 2) 100 0)
          (+ 
           (if (>= 1 2) 200 0)
           (if (= 2 3) 400 0)))))))))

(define RIGHT 1)

(define test-right
  `((define (main) (cons 0 step))
    (define (step ai-state world-state)
      (cons ai-state ,RIGHT))))

(define functions
  `(
  (define (left-of dir) (right-of (right-of (right-of dir))))
    (define (right-of dir) (if (> (+ dir 1) 3) 0 (+ dir 1)))
    (define (add-pos p1 p2)
      (cons (+ (car p1) (car p2)) (+ (cdr p1) (cdr p2))))
    (define (dir-offset dir)
      ;; "Flipped" Y
      (if (= dir 0) (cons 0 -1) 
          (if (= dir 1) (cons 1 0)
              (if (= dir 2) (cons 0 1)
                  (cons -1 0)))))
    (define (item-at-pos pos map)
      (item-at 
       (item-at map (cdr pos))
       (car pos)))
    (define (item-at lst index)
      (if (= 0 index) (car lst)
          (item-at (cdr lst) (- index 1))))
    (define (empty-space item)
      (if (= item 0) 0 1))
    (define (world-state-map ws)
      (car ws))
    (define (my-pos world-state)
      (car (cdr ;; lambda-man's position
            (car (cdr world-state)))))))

;; Step state is just current dir. Follow left wall, more or less.
(define test-follow-left
  `((define (main) (cons 1 step))
    (define (step dir world-state)
      (try-dir (left-of dir) world-state))
    ;; Try direction, then direction to the right of it
    (define (try-dir dir world-state)
      (if (empty-space (item-at-pos (add-pos (my-pos world-state) (dir-offset dir)) 
                                    (world-state-map world-state)))
          (cons dir dir)
          (try-dir (right-of dir) world-state)))
    ,@functions))

;; STATE is direction * following (0-9 = left, 10-19 = right)
(define follow-timed-switch
  `((define (main) (cons (switch-state 1 0) step))
    (define (step ss world-state)
      (try-dir 
       ((following-fn-op (ss-following ss)) (ss-dir ss)) 
       world-state 
       (ss-following ss)))
    ;; Try direction, then direction to the right of it
    (define (try-dir dir world-state following)
      (if (empty-space (item-at-pos (add-pos (my-pos world-state) (dir-offset dir)) 
                                    (world-state-map world-state)))
          (cons (switch-state dir (bump-following following)) dir)
          (try-dir ((following-fn following) dir) world-state following)))
    (define (switch-state dir following)
      (cons dir following))
    (define (ss-dir ss) (car ss))
    (define (following-fn f) (if (>= f 10) 
                               right-of
                               left-of))
    (define (following-fn-op f) (if (>= f 10)
                                    left-of
                                    right-of))
    (define (ss-following ss) (cdr ss))
    (define (bump-following f) (if (>= f 19) 0 (+ 1 f)))
    ,@functions))