Return Styles: Pseud0ch, Terminal, Valhalla, NES, Geocities, Blue Moon. Entire thread

ITT we write SKI interpreters

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

Name: Anonymous 2007-08-12 12:00 ID:Heaven

My other car is a cdr.

Name: Anonymous 2007-08-12 12:02 ID:Heaven

although I dunno if Ka should => a, or whether it should be just => Ka. I mean, technically K should take two arguments, so that's what I enforced

Name: Anonymous 2007-08-12 12:11 ID:bkXSxtYm

PROTIP: give some meaninful, context-specific names to c[ad]+r.

Name: Anonymous 2007-08-12 12:20 ID:Heaven

>>4
good point

Name: Anonymous 2007-08-12 14:14 ID:yy18Oo76

;; List utility to append a set of arguments together into a list
(define (append-coerced . args)
  (define (coerce x)
    (if (list? x) x (list x)))
  (apply append (map coerce args)))

 
;; Combinator parameters
(define (first-param? tree) (cons? (cdr tree)))
(define (second-param? tree) (cons? (cddr tree)))
(define (third-param? tree) (cons? (cdddr tree)))
(define (first-param-value tree) (cadr tree))
(define (second-param-value tree) (caddr tree))
(define (third-param-value tree) (cadddr tree))
 
;; S combinator
(define (s-remainder tree) (cdr (cdddr tree)))
 
(define (s-remainder? tree) (cons? (cdr (cdddr tree))))
 
(define (s-combinator? tree)
  (and (eq? (car tree) 'S)
       (first-param? tree)
       (second-param? tree)
       (third-param? tree)))
 
(define (apply-s tree)
  (list (append-coerced (first-param-value tree)
                        (third-param-value tree)
                        (list (append-coerced (second-param-value tree)
                                              (third-param-value tree))))))
 
(define (reduce-s tree)
  (let ((application (apply-s tree)))
    (if (s-remainder? tree)
        (append application (s-reaminder tree))
        application)))
 
;; K combinator
(define (k-combinator? tree)
  (and (eq? (car tree) 'K)
       (first-param? tree)
       (second-param? tree)))
 
(define (k-remainder tree) (cdddr tree))
 
(define (reduce-k tree)
  (cons (first-param-value tree) (k-remainder tree)))
 
;; I combinator
(define (i-remainder tree) (cdr tree))
 
(define (i-combinator? tree)
  (eq? (car tree) 'I))

(define (reduce-i tree)
  (list (i-remainder tree)))
 
;; Reduce subtrees
(define (subtree-or-next-tree tree)
  (let* ((subtree (reduce (car tree) #t))
         (extratree (if (null? subtree) (reduce (cdr tree) #f))))
    (cond ((not (null? subtree))
           (append-coerced subtree (cdr tree)))
          ((not (null? extratree))
           (append-coerced (car tree) extratree))
          (else tree))))
 
;; Reduce left-associative combinator
(define (reduce-combinator tree)
  (if (first-param? tree)
      (cond ((k-combinator? tree) (reduce-k tree))
            ((s-combinator? tree) (reduce-s tree))
            ((i-combinator? tree) (reduce-i tree))
            (else (subtree-or-next-tree tree)))
      (subtree-or-next-tree tree)))

;; Reduce a tree
(define (reduce tree first)
  (if (and (cons? tree) (or first (list? (car tree))))
      (reduce-combinator tree)
      '()))
 
;; Iterative reduction function
(define (ski-reduce tree)
  (let loop ((previous tree))
    (print previous) (display "\n")
    (let ((reduction (reduce previous #t)))
      (if (equal? reduction previous)
          reduction
          (loop reduction)))))

Name: Anonymous 2007-08-12 14:46 ID:Heaven

IM R5RS
DO YOU WANT SCHEME?
DO YOU WANT PRINT, CONS??
FUCKING SFRI
R6RS IS A MURDERER


(define print display)
(define cons? pair?)

Name: Anonymous 2007-08-12 14:51 ID:IPNLg5cp

(define (I x) x)
(define (K x y) x)
(define (S x y z) (x z (y z)))

#;> (S. K. I. I.)
#<procedure i.>



uh, that was hard....

Name: Anonymous 2007-08-12 16:58 ID:Heaven

>>8
not flexible/useful

Name: Anonymous 2007-08-12 17:16 ID:IPNLg5cp

>>9
yeah and yours was... lol

Name: Anonymous 2007-08-12 18:36 ID:Heaven

>>10
yes. heard of peano's arithmetic?

Name: Anonymous 2007-08-12 19:09 ID:Heaven

saging this thread for ignorance of godel

Name: Anonymous 2010-12-17 1:24

Are you GAY?
Are you a NIGGER?
Are you a GAY NIGGER?

If you answered "Yes" to all of the above questions, then GNAA (GAY NIGGER ASSOCIATION OF AMERICA) might be exactly what you've been looking for!

Name: Anonymous 2010-12-26 11:18

Name: Anonymous 2011-02-03 1:37

Newer Posts
Don't change these.
Name: Email:
Entire Thread Thread List
All trademarks and copyrights on this site are owned by their respective parties. All comments and posts are the responsibility of their own posters.
- Tinychan + 2ch Mode -