Name: anal leakage 2007-08-12 11:56 ID:yy18Oo76
(define (ski-eval tree)
(define (eval tree)
(define (append-coerced . args)
(define (coerce x)
(if (list? x) x (list x)))
(apply append (map coerce args)))
(define (try-subtrees tree)
(let* ((subtree (eval (car tree)))
(extratree (if (null? subtree) (eval (cdr tree)))))
(cond ((not (null? subtree))
(append-coerced subtree (cdr tree)))
((not (null? extratree))
(append-coerced (car tree) extratree))
(else tree))))
(define (apply-s tree)
(list
(append-coerced (cadr tree) (cadddr tree)
(list (append-coerced (caddr tree) (cadddr tree))))))
(if (cons? tree)
(if (cons? (cdr tree))
(cond ((and (eq? (car tree) 'K)
(cons? (cdr tree))
(cons? (cddr tree)))
(cons (cadr tree) (cdddr tree)))
((and (eq? (car tree) 'S)
(cons? (cdr tree))
(cons? (cddr tree))
(cons? (cdddr tree)))
(let ((res (apply-s tree)))
(if (cons? (cdr (cdddr tree)))
(append res (cdr (cdddr tree)))
res)))
((eq? (car tree) 'I) (list (cdr tree)))
(else (try-subtrees tree)))
(try-subtrees tree))
'()))
(let loop ((last tree))
(print last) (display "\n")
(let ((result (eval last)))
(if (equal? result last)
result
(loop result)))))!examples!
(ski-eval '(K K a K z j))
(K K a K z j)
(K K z j)
(K j)
(K j)
(ski-eval '(S I I α))
(S I I α)
((I α (I α)))
((α (I α)))
(α (α))
(α α)
(α α)
(ski-eval '(S (K α) (S I I) β))
(S (K α) (S I I) β)
((K α β (S I I β)))
(α (S I I β))
(α (I β (I β)))
(α (β (I β)))
(α β (β))
(α β β)
(α β β)