Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 58 lines (53 sloc) 1.748 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
(define-condition invalid-arguments ()()
  (:report (lambda (condition stream)
(princ "Not enough arguments to apply current combinator" stream))))

(define-condition invalid-combinator ()()
  (:report (lambda (condition stream)
(princ "Trying to execute invalid combinator." stream))))

(defun ski-step (program)
  (cond
    ((eq (car program) :I)
     (or (cdr program) (error 'invalid-arguments)))
    ((eq (car program) :K)
     (if (> (length program) 2)
(cons (cadr program)
(cdddr program))
(error 'invalid-arguments)))
     ((eq (car program) :S)
      (if (> (length program) 3)
(cons (cadr program)
(cons (cadddr program)
(cons (list (caddr program)
(cadddr program))
(cddddr program))))
(error 'invalid-arguments)))
     (t (error 'invalid-combinator))))

(defun print-program (program)
  (princ program))

(defun ski-eval (program)
  (handler-case
      (cond
((null program) program)
((listp (car program))
(ski-eval (cons (ski-step (car program))
(cdr program))))
(t (ski-eval (ski-step program))))
    (invalid-arguments () program)))
(defun test-case (tcase)
  (let ((result (ski-eval (car tcase)))
(expected (cadr tcase)))
    (unless (equal result expected)
      (fresh-line) (princ "========================================")
      (fresh-line) (princ "Execution of program: ") (print-program (car tcase))
      (fresh-line) (princ "gave: ") (print-program result)
      (fresh-line) (princ "instead of: ") (print-program expected) (fresh-line))))

(defun test ()
  (let ((tests
'(((:I) (:I))
((:I :I) (:I))
((:K) (:K))
((:K :K) (:K :K))
((:K :K :I) (:K))
((:K :I :K) (:I))
((:K :I :K :I) (:I)))))
    (map nil #'test-case tests)))
Something went wrong with that request. Please try again.