Advertisement
bigmazi

Untitled

Nov 24th, 2022
525
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Lisp 4.74 KB | None | 0 0
  1. (defmacro out (&rest args) (print args))
  2.  
  3. (defun default () t)
  4. (defun valof (x) x)
  5.  
  6. (defun split (src d)
  7.     (cond
  8.         ((null src) (list nil))
  9.         ((eq (car src) d) (cons nil (split (cdr src) d)))
  10.         (t (let ((x (split (cdr src) d))) (cons (cons (car src) (car x)) (cdr x))))
  11.     ))
  12.  
  13. (defun split-once (src d)
  14.     (cond
  15.         ((null src) (list nil))
  16.         ((eq (car src) d) (list nil (cdr src)))
  17.         (t (let ((x (split-once (cdr src) d))) (cons (cons (car src) (car x)) (cdr x))))
  18.     ))
  19.  
  20. (defmacro sub (&rest src)
  21.     (let ((x (split-once (cdr src) ':)))
  22.         `(defun ,(car src) ,(car x) ,(cadr x))
  23.     ))
  24.    
  25. (defmacro save (&rest src)
  26.     (let ((x (split-once src 'as)))
  27.         `(let ((,(caadr x) ,(car x))) ,(cdadr x))
  28.     ))
  29.    
  30. (defmacro fn (&rest src)
  31.     (let ((sp=> (split-once src '=>))) (let  ((spas (split-once (cadr sp=>) 'as)))
  32.         `(let ((,(caadr spas) (lambda ,(car sp=>) ,(car spas)))) ,(cdadr spas))
  33.     )))
  34.    
  35. (defmacro switch (&rest src)
  36.     (let
  37.         ((   y ( lambda(x)(split x ':) )   ))
  38.         (cons 'cond (mapcar y (split src '\\)))
  39.     ))
  40.    
  41. (defmacro exe (&rest src)
  42.     (let ((x (split-once src 'then)))
  43.         `(let ((~~dummy~~ ,(car x))) ,(cadr x))
  44.     ))
  45.    
  46. (defmacro assign (&rest src)
  47.     (let ((x (split-once src 'to)))
  48.         `(EXE setf ,(caadr x) ,(car x) THEN ,@(cdadr x))
  49.     ))
  50.    
  51.  
  52. ;(print (macroexpand '(ASSIGN valof 10 TO x fn a b c d e)))
  53.    
  54. (defmacro ?? (&rest src)
  55.     (SAVE split-once src 'y? AS s-y?
  56.     SAVE car s-y? AS predicate
  57.     SAVE split-once (cadr s-y?) 'n? AS s-n?
  58.     SAVE car  s-n? AS yes-fun
  59.     SAVE cadr s-n? AS no-fun
  60.     valof `(if ,predicate ,yes-fun ,no-fun)
  61.     ))
  62.    
  63. (sub exec-loop body-fn condition-fn :
  64.     ?? apply condition-fn nil
  65.     Y? SAVE apply body-fn nil AS no-breaks
  66.        valof (?? valof no-breaks Y? exec-loop body-fn condition-fn N? valof nil)
  67.     N? valof nil
  68. )
  69.    
  70. (defmacro while (&rest src)
  71.     (
  72.     SAVE split-once src 'cycle AS split-cycle
  73.     SAVE car   split-cycle  AS predicate
  74.     SAVE caadr split-cycle  AS body
  75.     SAVE cdadr split-cycle  AS ret
  76.     SAVE valof `(lambda () ,body)      AS body-fn
  77.     SAVE valof `(lambda () ,predicate) AS condition-fn
  78.     valof `(EXE exec-loop ,body-fn ,condition-fn THEN ,@ret)
  79.     ))
  80.    
  81. (sub stop-loop : valof nil)
  82. (sub next-iter : valof t)
  83.  
  84. (sub whiletry :
  85.     SAVE valof 0 AS x
  86.     WHILE < x 10 CYCLE (EXE print x THEN ASSIGN + x 1 TO x NEXT-ITER)
  87.     * x 2
  88. )
  89.  
  90. ;(print(whiletry))
  91. ;(print (macroexpand '(exe + a b then - x y)))
  92.    
  93. ;(sub try src : fn x => + x 10 as f mapcar f src)
  94. ;(print (try '(1 2 3 4 5)))
  95.  
  96. (defmacro match2 (&rest src)
  97. (
  98.         FN x => split x ': AS split-colon
  99.         cons 'cond (mapcar split-colon (split src '\\))
  100. ))
  101.    
  102. (SUB split2 src d :
  103.     SWITCH null src       : list nil
  104.         \\ eq (car src) d : cons nil (split2 (cdr src) d)
  105.         \\ default        : SAVE split (cdr src) d AS x
  106.                             cons (cons (car src) (car x)) (cdr x)
  107. )
  108.  
  109. (SUB where< src pivot :
  110.     SAVE car src AS head
  111.     SAVE cdr src AS tail
  112.     SWITCH null src     : valof nil
  113.         \\ < head pivot : cons head (where< tail pivot)
  114.         \\ default      : where< tail pivot
  115. )
  116.  
  117. (SUB where>= src pivot :
  118.     SAVE car src AS head
  119.     SAVE cdr src AS tail
  120.     SWITCH null src      : valof nil
  121.         \\ >= head pivot : cons head (where>= tail pivot)
  122.         \\ default       : where>= tail pivot
  123. )
  124.  
  125. (SUB qsort src :
  126.     ?? null src
  127.     Y? valof nil
  128.     N? SAVE car src AS pivot
  129.        SAVE cdr src AS observable
  130.        SAVE qsort (where<  observable pivot) AS low-src
  131.        SAVE qsort (where>= observable pivot) AS high-src
  132.        append low-src (list pivot) high-src
  133.                      
  134. )
  135.  
  136. (SUB bubble src :
  137.     SAVE copy-list src AS xs
  138.     SAVE valof xs AS i
  139.     WHILE not (null i) CYCLE
  140.     (
  141.         SAVE cdr i AS next-i
  142.        
  143.         SAVE valof xs AS j
  144.         WHILE not (null (cdr j)) CYCLE
  145.         (
  146.             SAVE cdr j AS next-j
  147.        
  148.             SAVE car  j AS low-val
  149.             SAVE cadr j AS high-val
  150.            
  151.             EXE ?? > low-val high-val
  152.                 Y? SAVE valof low-val AS tmp
  153.                    ASSIGN cadr j    TO (car  j)
  154.                    ASSIGN valof tmp TO (cadr j)
  155.                    default
  156.                 N? default
  157.             THEN
  158.            
  159.             ASSIGN valof next-j TO j
  160.             next-iter
  161.         )
  162.        
  163.         ASSIGN valof next-i TO i
  164.         next-iter
  165.     )
  166.     valof xs
  167. )
  168.  
  169. (print (bubble '(2 8 31 6 0 0 1 88 6 1)))
  170. ;(print (cdr nil))
  171.  
  172. ;(print (split2 '(1 2 3 ! 4 5 6) '!))    
  173. ;(print (split2 '(1 2 3 4 ! a b c ! ! x nil z ! f ! ! h !) '!))
  174. ;(print (list< '(2 8 31 6 0 0 1 88 6 1)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement