combinators/combinators.scm at master · matchcase/combinators · GitHub

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
#!/usr/bin/scheme --script
;; combinators.scm - A Small Combinator Calculus Evaluator
;; © 2023 Sarthak Shah (cel7t)

(define-syntax curry
  (syntax-rules (:lock)
    [(_ a :lock (b ...) . rest)
     (curry (a (curry b ...)) :lock . rest)]
    [(_ a :lock b . rest)
     (curry (a b) :lock . rest)]
    [(_ a :lock)
     a]
    [(_ (a ...) . rest)
     (curry (curry a ...) :lock . rest)]
    [(_ a . rest)
     (curry a :lock . rest)]))

(define S
  (lambda (x) (lambda (y) (lambda (z) ((x z) (y z))))))

(define K
  (lambda (x) (lambda (y) x)))

(define I
  (lambda (x) x))

(define Y
  (lambda (h)
    ((lambda (x) (h (lambda (z) ((x x) z))))
     (lambda (x) (h (lambda (z) ((x x) z)))))))

(define C1
  (curry S (S (K K) (S (K S) (S (K K) I))) (K (S (S (K S) (S (K K) I)) (K I)))))

(define C2
  (curry S (C1 S (C1 K (C1 S (S (C1 C1 I) (K I))))) (K (C1 K I))))

(define PAIR
  (curry  C2 (C1 C1 (C1 C2 (C1 (C2 I) I))) I))

(define ZERO
  (curry S K))

(define SUCC
  (curry S (S (K S) K)))

(define ADD
  (curry C2 (C1 C1 (C2 I SUCC)) I))

(define MUL
  (curry C2 (C1 C2 (C2 (C1 C1 I) (C1 ADD I))) ZERO))

(define FIRST
  (curry K))

(define SECOND
  (curry S K))

(define M
  (curry S (C1 MUL (C2 I FIRST)) (C2 I SECOND)))

(define I2
  (curry C1 SUCC (C2 I SECOND)))

(define ONE
  (curry (SUCC ZERO)))

(define FAC*
  (curry S (C1 PAIR M) I2))

(define FAC
  (curry C2 (C2 I FAC*) (PAIR ONE ONE)))

(define (TO-CHURCH n)
  (let loop ((i n))
    (if (> i 0)
      (SUCC (loop (- i 1)))
      ZERO)))

(let [(to-parse (cadr (command-line)))]
  (cond
    [(string? to-parse)
     (begin
       (display "=> ")
       (display
         (eval
           `(curry
              ,@(read
                  (open-input-string
                    (if (and (not (null? (cddr (command-line))))
                             (not (null? (cdddr (command-line))))
                             (equal? (cadddr (command-line))
                                     "number"))
                      (string-append "(" to-parse " 1+ 0)")
                      (string-append "(" to-parse ")")))))))
       (newline))]
    [else
      (begin
        (display "The argument should be a string!")
        (display to-parse)
        (newline))]))