48 小时编写sheme解释器的学习笔记-stdlib.scm

切换背景色
主题: 字体: 切换行号 全选代码块(Ctrl+C复制) 刘鑫1年前贴出, Scheme 语言
Scheme代码: 48 小时编写sheme解释器的学习笔记-stdlib.scm
01 (define (caar pair) (car (car pair)))
02 (define (cadr pair) (car (cdr pair)))
03 (define (cdar pair) (cdr (car pair)))
04 (define (cddr pair) (cdr (cdr pair)))
05 (define (caaar pair) (car (car (car pair))))
06 (define (caadr pair) (car (car (cdr pair))))
07 (define (cadar pair) (car (cdr (car pair))))
08 (define (caddr pair) (car (cdr (cdr pair))))
09 (define (cdaar pair) (cdr (car (car pair))))
10 (define (cdadr pair) (cdr (car (cdr pair))))
11 (define (cddar pair) (cdr (cdr (car pair))))
12 (define (cdddr pair) (cdr (cdr (cdr pair))))
13 (define (caaaar pair) (car (car (car (car pair)))))
14 (define (caaadr pair) (car (car (car (cdr pair)))))
15 (define (caadar pair) (car (car (cdr (car pair)))))
16 (define (caaddr pair) (car (car (cdr (cdr pair)))))
17 (define (cadaar pair) (car (cdr (car (car pair)))))
18 (define (cadadr pair) (car (cdr (car (cdr pair)))))
19 (define (caddar pair) (car (cdr (cdr (car pair)))))
20 (define (cadddr pair) (car (cdr (cdr (cdr pair)))))
21 (define (cdaaar pair) (cdr (car (car (car pair)))))
22 (define (cdaadr pair) (cdr (car (car (cdr pair)))))
23 (define (cdadar pair) (cdr (car (cdr (car pair)))))
24 (define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
25 (define (cddaar pair) (cdr (cdr (car (car pair)))))
26 (define (cddadr pair) (cdr (cdr (car (cdr pair)))))
27 (define (cdddar pair) (cdr (cdr (cdr (car pair)))))
28 (define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))
29
30 (define (not x)            (if x #f #t))
31 (define (null? obj)        (if (eqv? obj '()) #t #f))
32 (define (id obj)           obj)
33 (define (flip func)        (lambda (arg1 arg2) (func arg2 arg1)))
34 (define (curry func arg1)  (lambda (arg) (func arg1 arg)))
35 (define (compose f g)      (lambda (arg) (f (g arg))))
36
37 (define (foldl func accum lst)
38   (if (null? lst)
39       accum
40       (foldl func (func accum (car lst)) (cdr lst))))
41
42 (define (foldr func accum lst)
43   (if (null? lst)
44       accum
45       (func (car lst) (foldr func accum (cdr lst)))))
46
47 (define (unfold func init pred)
48   (if (pred init)
49       (cons init '())
50       (cons init (unfold func (func init) pred))))
51
52 (define fold foldl)
53 (define reduce fold)
54
55 (define zero?              (curry = 0))
56 (define positive?          (curry < 0))
57 (define negative?          (curry > 0))
58 (define (odd? num)         (= (mod num 2) 1))
59 (define (even? num)        (= (mod num 2) 0))
60 (define (max x . num-list) (fold (lambda (y z) (if (> y z) y z)) x num-list))
61 (define (min x . num-list) (fold (lambda (y z) (if (< y z) y z)) x num-list))
62 (define (list . objs)       objs)
63 (define (length lst)        (fold (lambda (x y) (+ x 1)) 0 lst))
64 (define (append lst . lsts) (foldr (flip (curry foldr cons)) lst lsts))
65 (define (reverse lst)       (fold (flip cons) '() lst))
66 (define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
67 (define (memq obj lst)       (fold (mem-helper (curry eq? obj) id) #f lst))
68 (define (memv obj lst)       (fold (mem-helper (curry eqv? obj) id) #f lst))
69 (define (member obj lst)     (fold (mem-helper (curry equal? obj) id) #f lst))
70 (define (assq obj alist)     (fold (mem-helper (curry eq? obj) car) #f alist))
71 (define (assv obj alist)     (fold (mem-helper (curry eqv? obj) car) #f alist))
72 (define (assoc obj alist)    (fold (mem-helper (curry equal? obj) car) #f alist))
73
74 (define (map func lst)      (foldr (lambda (x y) (cons (func x) y)) '() lst))
75 (define (filter pred lst)   (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
76
77 (define (sum . lst)         (fold + 0 lst))
78 (define (product . lst)     (fold * 1 lst))
79 (define (and . lst)         (fold && #t lst))
80 (define (or . lst)          (fold || #f lst))
81 (define (any? pred . lst)   (apply or (map pred lst)))
82 (define (every? pred . lst) (apply and (map pred lst)))
返回正常查看模式 返回代码发芽网首页