Skip to content

Instantly share code, notes, and snippets.

@Lovesan
Created July 5, 2021 16:29
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Lovesan/bd837be9a8ccf89aac7f871887606570 to your computer and use it in GitHub Desktop.
Save Lovesan/bd837be9a8ccf89aac7f871887606570 to your computer and use it in GitHub Desktop.
(set-macro-character #\→ (lambda (s c)
(declare (ignore s c))
(error "Unexpected '→'")))
(set-macro-character #\λ
(lambda (s c)
(declare (ignore c))
(loop :with arg = (read s t nil t)
:for next = (peek-char t s t nil t)
:until (eql next #\→)
:collect (read s t nil t) :into more-args
:finally
(read-char s t nil t)
(let ((body (read s t nil t)))
(labels ((compose (args)
(if (endp args)
body
`(lambda (,(first args))
,(compose (rest args))))))
(return (compose (list* arg more-args))))))))
(set-macro-character #\$
(lambda (s c)
(declare (ignore c))
(let ((f (read s t nil t))
(arg (read s t nil t)))
`(funcall ,f ,arg))))
(set-macro-character #\≤ (lambda (s c) (declare (ignore s c)) '<=))
(set-macro-character #\] (lambda (s c)
(declare (ignore s c))
(error "Unexpected ']'")))
(set-macro-character #\[
(lambda (s c)
(declare (ignore c))
(let ((body (read-delimited-list #\] s t)))
(destructuring-bind (left op right &rest other) body
`(,op ,left ,right ,@other)))))
(defmacro ? (condition if-true ?? if-false)
(declare (ignore ??))
`(if ,condition ,if-true ,if-false))
#|
$(λ f → (λ y → $y y
λ y → $f λ x → $$y y x)
λ f n → [[n ≤ 1] ? 1 ?? [n * $f[n - 1]]])
5
|#
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment