SHARE
TWEET

MAY42

z66is May 23rd, 2019 (edited) 88 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ;;; Zelah Hutchinson
  2. ;;; f  o  u  r
  3.  
  4. (define-macro (pr . args) (cons 'prn args))
  5.  
  6. (define-macro (prnt exp . j) (list 'begin (list 'newline) (list 'display "--------------------") (list 'newline) (list 'elist (list 'quote exp)) (list 'newline) (list 'display "-------result-------") (list 'newline) (list 'elist exp) (list 'newline)))
  7.  
  8. (define-macro (prn exp j) (list 'if (list (list 'n==== exp) (list 'quote j)) (list 'begin (list 'prnt exp) (list 'display "------expected------") (list 'newline) (list 'elist (list 'quote j)) (list 'newline))))
  9.  
  10. (define-macro (fc fn . xs) (list 'apply fn (list 'quote xs)))
  11.  
  12. (define-macro (o x) (list 'lambda (cons 'o 'oo) x))
  13.  
  14. (define-macro (p x) (list 'lambda (cons 'p 'pp) x))
  15.  
  16. (define-macro (oo x) (list 'lambda (cons 'o (cons 'oo 'ooo)) x))
  17.  
  18. (define-macro (pp x) (list 'lambda (cons 'p (cons 'pp 'ppp)) x))
  19.  
  20. (define-macro (ooo x) (list 'lambda (cons 'o (cons 'oo (cons 'ooo 'oooo))) x))
  21.  
  22. (define-macro (ppp x) (list 'lambda (cons 'p (cons 'pp (cons 'ppp 'pppp))) x))
  23.  
  24. ;;;
  25.  
  26. (define *delimiter* ",")
  27.  
  28. (define *spaces* " ")
  29.  
  30. (define (elist exp) (if (list? exp) (let ((sp *spaces*)) (display "(") (display sp) (for-each (lambda (x) (write x) (display sp) (display *delimiter*) (display sp)) exp) (display ")")) (write exp)))
  31.  
  32. ;;;
  33.  
  34. (newline)
  35.  
  36. ;;;
  37.  
  38. (define pred (p (o (if (fc p o) (or o #t)))))
  39.  
  40. (define less (p (o (if (< o p) o))))
  41.  
  42. (define more (p (o (if (> o p) o))))
  43.  
  44. (define == (p (o (if (eq? o p) o))))
  45.  
  46. (define === (p (o (if (eqv? o p) o))))
  47.  
  48. (define ==== (p (o (if (equal? o p) o))))
  49.  
  50. (define y= (p (o (if (= o p) o))))
  51.  
  52. (define n= (p (o (if (not (= o p)) o))))
  53.  
  54. (define n== (p (o (if (not (eq? o p)) o))))
  55.  
  56. (define n=== (p (o (if (not (eqv? o p)) o))))
  57.  
  58. (define n==== (p (o (if (not (equal? o p)) o))))
  59.  
  60. (define make-adder (p (o (if (number? o) (+ o p)))))
  61.  
  62. ;;;
  63.  
  64. (define (predor pred . preds) (define (predor xs preds) (if preds (or (apply (car preds) xs) (predor xs (cdr preds))) ())) (lambda (x . s) (let ((xs (cons x s))) (or (apply pred xs) (predor xs preds)))))
  65.  
  66. (define (predand pred . preds) (define (predand xs preds) (if preds (and (apply (car preds) xs) (predand xs (cdr preds))) (or (car xs) #t))) (lambda (x . s) (let ((xs (cons x s))) (if (apply pred xs) (predand xs preds)))))
  67.  
  68. (define (predfn fn . preds) (lambda (x . s) (let ((xs (cons x s))) (if (apply (apply predand preds) xs) (apply fn xs)))))
  69.  
  70. (define (fnfn fn . fns) (define (fnfn x fns) (if fns (fnfn ((car fns) x) (cdr fns)) x)) (lambda (x . s) (fnfn (apply fn (cons x s)) fns)))
  71.  
  72. (define (type fn . preds)
  73. (o (or ((predfn fn (apply predand preds)) o) o)))
  74.  
  75. (define (mapped fn) (lambda (x . s) (if s (map fn (cons x s)) (fn x))))
  76.  
  77. (define (tree-mapped fn) (define (tree-map x . s)  (if s (map tree-map (cons x s)) (if (pair? x) (map tree-map x) (fn x)))) (lambda (x . s) (apply tree-map (cons x s))))
  78.  
  79. (define 2x (o (* 2 o)))
  80.  
  81. (define 2x (type 2x number?))
  82.  
  83. (define 2x (tree-mapped 2x))
  84.  
  85. ;;;
  86.  
  87. (define (nthcdr n lst) (if (= 0 n) lst (nthcdr (- n 1) (cdr lst))))
  88.  
  89. (define (subseq lst beg end) (define (seq lst end acc) (if (= 0 end) (reverse acc) (seq (cdr lst) (- end 1) (cons (car lst) acc)))) (seq (nthcdr beg lst) (- end beg) ()))
  90.  
  91. (define (find-if fn lst) (if lst (if (fn (car lst)) (values (car lst) lst) (find-if fn (cdr lst)))))
  92.  
  93. ;;;
  94.  
  95. (define (last1 lst) (car (last-pair lst)))
  96.  
  97. (define last1 (mapped last1))
  98.  
  99. (define (single lst) (and (pair? lst) (not (cdr lst)) lst))
  100.  
  101. (define single (mapped single))
  102.  
  103. (define (append1 lst obj) (append lst (list obj)))
  104.  
  105. (define (conc1 lst obj) (append! lst (list obj)))
  106.  
  107. (define (mklist obj) (if (list? obj) obj (list obj)))
  108.  
  109. (define mklist (mapped mklist))
  110.  
  111. (define (longer x y) (define (len x) (if (number? x) x (if (string? x) (string-length x) (if (vector? x) (vector-length x) (if (list? x) (length x) (throw-error x)))))) (define (compare x y) (and (pair? x) (or (not y) (compare (cdr x) (cdr y))))) (values (if (if (if (list? x) (list? y)) (compare x y) (> (len x) (len y))) x) y x))
  112.  
  113. (define (shorter x y) (define (len x) (if (number? x) x (if (string? x) (string-length x) (if (vector? x) (vector-length x) (if (list? x) (length x) (throw-error x)))))) (define (compare x y) (and (pair? y) (or (not x) (compare (cdr y) (cdr x))))) (values (if (if (if (list? x) (list? y)) (compare x y) (< (len x) (len y))) (or x #t)) y x))
  114.  
  115. (define (filter fn lst) (define (fi fn lst acc) (if lst (let ((val (fn (car lst)))) (if val (fi fn (cdr lst) (cons val acc)) (fi fn (cdr lst) acc))) (reverse acc))) (fi fn lst ()))
  116.  
  117. (define (group source n) (define (rec source acc) (let ((rest (nthcdr n source))) (if (pair? rest) (rec rest (cons (subseq source 0 n) acc)) (reverse (cons source acc))))) (if (= 0 n) (error "zero length")) (if source (rec source ())))
  118.  
  119. (define (flatten x) (define (rec x acc) (if x (if (atom? x) (cons x acc) (rec (car x) (rec (cdr x) acc))) acc)) (rec x ()))
  120.  
  121. (define flatten (mapped flatten))
  122.  
  123. (define (prune test tree) (define (rec tree acc) (if tree (if (pair? (car tree)) (rec (cdr tree) (cons (rec (car tree) ()) acc)) (rec (cdr tree) (if (test (car tree)) acc (cons (car tree) acc)))) (reverse acc))) (rec tree ()))
  124.  
  125. (define (find2 fn lst) (if lst (let ((val (fn (car lst)))) (if val (values (car lst) val) (find2 fn (cdr lst)))) lst))
  126.  
  127. (define (before x y lst &key (test ==)) (if lst (let ((first (car lst))) (if ((test y) first) () (if ((test x) first) lst (before x y (cdr lst) :test test))))))
  128.  
  129. (define (after x y lst &key (test ==)) (let ((rest (before y x lst :test test))) (and rest (multiple-value-bind (a b) (find-if (test x) rest) b))))
  130.  
  131. (define (duplicate obj lst &key (test ==)) (multiple-value-bind (a b) (find-if (test obj) (cdr (multiple-value-bind (a b) (find-if (test obj) lst) b))) b))
  132.  
  133. ;;;
  134. ;;;
  135. ;;;
  136. ;;;
  137. ;;;
  138. ;;;
  139. ;;;
  140. ;;;
  141. ;;;
  142. ;;;
  143. ;;;
  144. ;;;
  145. ;;;
  146. ;;;
  147. ;;;
  148. ;;;
  149. ;;;
  150. ;;;
  151. ;;;
  152. ;;;
  153. ;;;
  154. ;;;
  155. ;;;
  156. ;;;
  157. ;;;
  158. ;;;
  159. ;;;
  160.  
  161. (define nine '(
  162. -4 -3 -2 -1 0 1 2 3 4
  163. ))
  164.  
  165. (define het '(
  166. #t () 1 "two"
  167. ))
  168.  
  169. (define love '(
  170. (i) (think i) (love) (you)
  171. ))
  172.  
  173. (define tree '(
  174. ((() 2) (3 4) (5 6)) ((7 8) (9 8) (7 6)) ((5 4) (3 2) ((i) (think i))) (((love) (you)) (#t ()) (1 "two")) ((-4 -3) (-2 -1) (0 1)) ((2 3) (4))
  175. ))
  176.  
  177. (define e '(
  178. 2 1 4 3 3 4 1 2 2 7 5 1 2 1 2 3
  179. ))
  180.  
  181. (pr nine
  182. (
  183. -4 -3 -2 -1 0 1 2 3 4
  184. ))
  185.  
  186. (pr het
  187. (
  188. #t () 1 "two"
  189. ))
  190.  
  191. (pr love
  192. (
  193. (i) (think i) (love) (you)
  194. ))
  195.  
  196. (pr tree
  197. (
  198. ((() 2) (3 4) (5 6)) ((7 8) (9 8) (7 6)) ((5 4) (3 2) ((i) (think i))) (((love) (you)) (#t ()) (1 "two")) ((-4 -3) (-2 -1) (0 1)) ((2 3) (4))
  199. ))
  200.  
  201. (pr e
  202. (
  203. 2 1 4 3 3 4 1 2 2 7 5 1 2 1 2 3
  204. ))
  205.  
  206. (pr 42
  207. 42
  208. )
  209.  
  210. (pr (list 42)
  211. (
  212. 42
  213. ))
  214.  
  215. (pr (list (list 42))
  216. (
  217. (42)
  218. ))
  219.  
  220. (pr (2x 2)
  221. 4
  222. )
  223.  
  224. (pr (2x 1 2 3 4)
  225. (
  226. 2 4 6 8
  227. ))
  228.  
  229. (pr (conc1 (list 1 2) 3)
  230. (
  231. 1 2 3
  232. ))
  233.  
  234. (pr nine
  235. (
  236. -4 -3 -2 -1 0 1 2 3 4
  237. ))
  238.  
  239. (pr (map 2x nine)
  240. (
  241. -8 -6 -4 -2 0 2 4 6 8
  242. ))
  243.  
  244. (pr (apply 2x nine)
  245. (
  246. -8 -6 -4 -2 0 2 4 6 8
  247. ))
  248.  
  249. (pr (map odd? nine)
  250. (
  251. () #t () #t () #t () #t ()
  252. ))
  253.  
  254. (pr (map (less 0) nine)
  255. (
  256. -4 -3 -2 -1 () () () () ()
  257. ))
  258.  
  259. (pr (map (more 0) nine)
  260. (
  261. () () () () () 1 2 3 4
  262. ))
  263.  
  264. (pr (map (y= 0) nine)
  265. (
  266. () () () () 0 () () () ()
  267. ))
  268.  
  269. (pr (map (n= 0) nine)
  270. (
  271. -4 -3 -2 -1 () 1 2 3 4
  272. ))
  273.  
  274. (pr (map (make-adder 10) nine)
  275. (
  276. 6 7 8 9 10 11 12 13 14
  277. ))
  278.  
  279. (pr (map (make-adder -10) nine)
  280. (
  281. -14 -13 -12 -11 -10 -9 -8 -7 -6
  282. ))
  283.  
  284. (pr (map (predor (predand (less 0) odd?) (predand (more 0) even?)) nine)
  285. (
  286. () -3 () -1 () () 2 () 4
  287. ))
  288.  
  289. (pr (map (predfn (fnfn 2x (make-adder 10) -) (predor (more 2) (less -1)) odd?) nine)
  290. (
  291. () -4 () () () () () -16 ()
  292. ))
  293.  
  294. (pr (nthcdr 5 nine)
  295. (
  296. 1 2 3 4
  297. ))
  298.  
  299. (pr (subseq nine 5 8)
  300. (
  301. 1 2 3
  302. ))
  303.  
  304. (pr (last1 nine)
  305. 4
  306. )
  307.  
  308. (pr (filter (predfn (fnfn car (make-adder -4)) single) (group nine 2))
  309. (
  310. 0
  311. ))
  312.  
  313. (pr (multiple-value-bind (itm prd) (find2 odd? nine) (list itm prd))
  314. (
  315. -3 #t
  316. ))
  317.  
  318. (pr (multiple-value-bind (itm prd) (find2 (more 4) nine) (list itm prd))
  319. (
  320. () ()
  321. ))
  322.  
  323. (pr het
  324. (
  325. #t () 1 "two"
  326. ))
  327.  
  328. (pr (find-if not het)
  329. ()
  330. )
  331.  
  332. (pr (multiple-value-bind (itm lst) (find-if not het) lst)
  333. (
  334. () 1 "two"
  335. ))
  336.  
  337. (pr (map mklist het)
  338. (
  339. (#t) () (1) ("two")
  340. ))
  341.  
  342. (pr (longer het "hat")
  343. (
  344. #t () 1 "two"
  345. ))
  346.  
  347. (pr (multiple-value-bind (a b c) (shorter () het) (list a b c))
  348. (
  349. #t (#t () 1 "two") ()
  350. ))
  351.  
  352. (pr (longer het 3)
  353. (
  354. #t () 1 "two"
  355. ))
  356.  
  357. (pr love
  358. (
  359. (i) (think i) (love) (you)
  360. ))
  361.  
  362. (pr (apply append (map single love))
  363. (
  364. i love you
  365. ))
  366.  
  367. (pr (append1 love '!)
  368. (
  369. (i) (think i) (love) (you) !
  370. ))
  371.  
  372. (pr tree
  373. (
  374. ((() 2) (3 4) (5 6)) ((7 8) (9 8) (7 6)) ((5 4) (3 2) ((i) (think i))) (((love) (you)) (#t ()) (1 "two")) ((-4 -3) (-2 -1) (0 1)) ((2 3) (4))
  375. ))
  376.  
  377. (pr (flatten tree)
  378. (
  379. 2 3 4 5 6 7 8 9 8 7 6 5 4 3 2 i think i love you #t 1 "two" -4 -3 -2 -1 0 1 2 3 4
  380. ))
  381.  
  382. (pr (prune (predand number? odd?) tree)
  383. (
  384. ((() 2) (4) (6)) ((8) (8) (6)) ((4) (2) ((i) (think i))) (((love) (you)) (#t ()) ("two")) ((-4) (-2) (0)) ((2) (4))
  385. ))
  386.  
  387. (pr (2x tree)
  388. (
  389. ((() 4) (6 8) (10 12)) ((14 16) (18 16) (14 12)) ((10 8) (6 4) ((i) (think i))) (((love) (you)) (#t ()) (2 "two")) ((-8 -6) (-4 -2) (0 2)) ((4 6) (8))
  390. ))
  391.  
  392. (pr (2x ((tree-mapped (type list number? (less 0))) (apply flatten tree)))
  393. (
  394. (4 6 8 10 12) (14 16 18 16 14 12) (10 8 6 4 i think i) (love you #t 2 "two") ((-8) (-6) (-4) (-2) 0 2) (4 6 8)
  395. ))
  396.  
  397. (pr e
  398. (
  399. 2 1 4 3 3 4 1 2 2 7 5 1 2 1 2 3
  400. ))
  401.  
  402. (pr (before 5 4 e :test y=)
  403. ()
  404. )
  405.  
  406. (pr (before 4 5 e :test y=)
  407. (
  408. 4 3 3 4 1 2 2 7 5 1 2 1 2 3
  409. ))
  410.  
  411. (pr (before 3 7 e :test more)
  412. (
  413. 4 3 3 4 1 2 2 7 5 1 2 1 2 3
  414. ))
  415.  
  416. (pr (list het nine)
  417. (
  418. (#t () 1 "two") (-4 -3 -2 -1 0 1 2 3 4)
  419. ))
  420.  
  421. (pr (longer het nine)
  422. ()
  423. )
  424.  
  425. (pr (multiple-value-bind (a b c) (longer het nine) (list a b c))
  426. (
  427. () (-4 -3 -2 -1 0 1 2 3 4) (#t () 1 "two")
  428. ))
  429.  
  430. (pr (multiple-value-bind (a b c) (longer nine het) (list a b c))
  431. (
  432. (-4 -3 -2 -1 0 1 2 3 4) (#t () 1 "two") (-4 -3 -2 -1 0 1 2 3 4)
  433. ))
  434.  
  435. (pr (multiple-value-bind (a b c) (shorter het nine) (list a b c))
  436. (
  437. (#t () 1 "two") (-4 -3 -2 -1 0 1 2 3 4) (#t () 1 "two")
  438. ))
  439.  
  440. (pr (multiple-value-bind (a b c) (shorter nine het) (list a b c))
  441. (
  442. () (#t () 1 "two") (-4 -3 -2 -1 0 1 2 3 4)
  443. ))
  444.  
  445. (pr (last1 het nine)
  446. (
  447. "two" 4
  448. ))
  449.  
  450. ;;;
  451.  
  452. ;;;
  453.  
  454. (pr (fc + 1 2 3)
  455. 6
  456. )
  457.  
  458. (pr ((ooo (+ oo oo)) 1 2 3)
  459. 4
  460. )
  461.  
  462. (pr ((ooo (+ o ooo)) 1 2 3)
  463. 4
  464. )
  465.  
  466. (pr (after 4 3 '(3 1 4 1 5 9))
  467. (
  468. 4 1 5 9
  469. ))
  470.  
  471. (pr (after 2 4 '(3 1 4 1 5 9))
  472. ()
  473. )
  474.  
  475. (pr (duplicate 1 '(3 1 4 1 5 9))
  476. (
  477. 1 5 9
  478. ))
  479.  
  480. (pr (duplicate 4 '(3 1 4 1 5 9))
  481. ()
  482. )
  483.  
  484. ;;;
  485.  
  486. ;;;
  487.  
  488. (newline) (newline)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top