#+sbcl (use-package :sb-mop) 
;;Метакласс классов-синглтонов. 
;;Сам является инстансом  
;;класса `standard-class' (а также наследником) 
;;Запоминаем его в переменную, хотя с таким же успехом 
;;можно было спрятать его в замыкание 
(defvar *singleton-metaclass* 
        (make-instance 'standard-class 
                       :name 'singleton-class 
                       :direct-superclasses                    
                                (list (find-class 'standard-class)) 
                       :direct-slots 
                                (list  
                                  (list :name 'instance 
                                        :initform nil 
                                        :initfunction (constantly nil))))) 
 
;;Позволяет получать доступ к классу по символу-имени 
(setf (find-class 'singleton-class) *singleton-metaclass*) 
 
;;Перегрузка стандартного конструктора CLOS 
;;Теперь для класса, для которого singleton-class 
;;является метаклассом, он создает инстанс только один раз. 
;;при повторном вызове - просто возвращает уже существующий 
(defmethod make-instance ((class singleton-class) &key)  
  (with-slots (instance) class 
    (or instance (setf instance (call-next-method))))) 
 
;;Обобщенная функция для доступа к инстансу класса 
;;Принимает как параметр объект-класс или символ-имя такого 
;;(хотя в принципе можно пользоваться и make-instance) 
(defgeneric instance (class-object)) 
 
(defmethod instance ((class-object singleton-class))  
  (slot-value class-object 'instance)) 
 
(defmethod instance ((class-object symbol)) 
  (instance (find-class class-object))) 
 
;;Позволяет инстансам singleton-class наследоваться от 
;;обычного standard-object. 
;;Это необходимо, если мы хотим пользоваться  
;;встроенными для standard-object механизмами CLOS, 
;;такими, как автоматическая инициализация инстансов 
;;в ходе вызова make-instance, или встраивать синглтоны в общую 
;;иерархию  
(defmethod validate-superclass ((class singleton-class) 
                                (superclass standard-object)) 
  t) 
 
;;Некий класс-синглтон. 
;;Инстанс созданного выше класса 'singleton-class' 
(defvar *my-singleton-class* 
              (make-instance 'singleton-class 
                             :name 'my-singleton 
                             :direct-superclasses  
                                (list (find-class 'standard-object)) 
                             :direct-slots 
                                (list 
                                  (list :name 'text-slot 
                                        :initform "" 
                                        :initfunction (constantly "") 
                                        :type 'string 
                                        :initargs '(:text-slot) 
                                        :readers '(text-slot) 
                                        :writers '((setf text-slot)))))) 
 
(setf (find-class 'my-singleton) *my-singleton-class*) 
 
;(defparameter *singleton-instance*  
;               (make-instance 'my-singeton :text-slot "Singleton instance!")) 
; 
;(instance 'my-singleton)  ==> #<MY-SINGLETON ....> 
; 
;(text-slot (make-instance 'my-singleton :text-slot "12345"))  
;       ==> "Singleton instance!" 
 
;;Конечно, не обязательно создавать классы вручную через 
;;make-instance, можно пользоваться и встроенным макросом defclass. 
;;На этот случай там есть параметр :metaclass 
(defclass another-singleton () 
  ((another-slot :initarg :another-slot 
                 :initform nil 
                 :accessor another-slot)) 
  (:metaclass singleton-class)) 

;;Church numerals  
 
(def |0| (l (f x) x)) 
 
(def |1| (l (f x) {f x})) 
 
(def |2| (l (f x) {f {f x}})) 
 
(def |3| (l (f x) {f {f {f x}}})) 
 
(def succ (l (n f x) {f {n f x}})) 
 
(def plus (l (n m) {m succ n})) 
 
(def mult (l (m n) {m {plus n} |0|})) 
 
(def pred (l (n f x) {n (l (g h) {h {g f}}) (l u x) (l u u)})) 
 
(def sub (l (m n) {n pred m})) 
 
(def churchify-numeral  
     (lambda (n) 
        (labels ((make-number (n) 
                     (if (<= n 0)  
                       |0| 
                       {succ (make-number (1- n))}))) 
          (let ((sym (intern (format nil "~a" n)))) 
            (setf (symbol-function sym) (make-number n)) 
            (setf (symbol-value sym) (symbol-function sym)))))) 
 
(def dechurchify-numeral (l (f) {f #'1+ 0})) 
 
;;Church booleans 
(def |true| (l (x y) x)) 
 
(def |false| (l (x y) y)) 
 
(def |and| (l (p q) {p q p})) 
 
(def |or| (l (p q) {p p q})) 
 
(def |not| (l (p a b) {p b a})) 
 
(def is-zero (l n {n (l x |false|) |true|})) 
 
(def less-then-or-equal (l (m n) {is-zero {sub m n}})) 
 
(def dechurchify-boolean (l f {if-then-else f T NIL})) 
 
;;If then else 
;;Не работает в силу applicative-order-evaluation: 
;;(def if-then-else-lambda (l (p a b) {p a b})) 
;; 
;;Костыли: 
(def force (l x (funcall x))) 
 
(defmacro delay (x) `(lambda () ,x)) 
 
(defmacro if-then-else (p a b) 
  `(force (funcall (funcall ,p (delay ,a)) (delay ,b)))) 
 
 
;;Church encoding for pairs 
(def |cons| (l (x y f) {f x y})) 
 
(def |car| (l p {p |true|})) 
 
(def |cdr| (l p {p |false|})) 
 
(def |nil| (l x |true|)) 
 
(def |null-p| (l p {p (l x {y |false|})})) 
 
;; Y combinator 
;(def Y (l g {(l x {g {x x}}) (l x {g {x x}})})) 
(def App-Order-Y (l g {(l x {g (l y {x x y})}) 
                       (l x {g (l y {x x y})})})) 
 
(def fact 
     {App-Order-Y 
       (l (f n) 
          (if-then-else {is-zero n} 
                        |1| 
                        {mult n {f {pred n}}}))}) 


(dechurchify-numeral (fact (churchify-numeral 5))) 
==> 120 

;;автокаррирующая лямбда 
(defmacro l (x &body body) 
  (cond 
    ((null x) (error "Lambda w/o arguments is not allowed here")) 
    ((atom x) `(lambda (,x) ,@body)) 
    (T (labels ((parse-lambda (args)  
                    `(lambda (,(car args)) 
                       ,@(if (null (rest args)) 
                           body 
                           (list (parse-lambda (cdr args))))))) 
         (parse-lambda x))))) 
 
;;ну просто 
(defmacro def (name args &body body) 
  `(progn ,(if (null body) 
             `(setf (symbol-function ',name) 
                    ,args) 
             `(defun ,name ,args ,@body)) 
          (defparameter ,name #',name))) 
 
( Парсер )
;;Теперь можно писать так: 
;;S K и I комбинаторы 
(def S (l (x y z) {x z {y z}})) 
 
(def K (l (x y) x)) 
 
(def I (l x {S K S x})) 
 
;;B C и W соответственно 
(def B {S {K S} K}) 
 
(def C {{S {{S {K {{S {K S}} K}}} S}} {K K}}) 
 
(def W {S S {K {S K K}}}) 

(defun match-state (ch state lexer-stream temp-out inverse-call) 
  (let* ((state-type (car state))) 
    (cond 
      ((atom-state-p state-type)  
                (multiple-value-bind 
                  (val count) (match-atom-state ch state  lexer-stream temp-out)  
                  (when (and (not inverse-call) val) 
                    (vector-push-extend ch temp-out)) 
                  (values val count))) 
      ((eq state-type :quant)  
                (let* ((min (first (second state))) 
                       (max (second (second state))) 
                       (count 0) 
                       (match nil) 
                       (real-state (third state)) 
                       (infinite-p (eq max :inf))) 
                  (handler-case 
                    (loop  
                          while (and (or infinite-p (< count max)) 
                                     (multiple-value-bind 
                                       (val cnt) (match-state ch real-state lexer-stream temp-out nil) 
                                       (incf count cnt) 
                                       val)) do 
                          (setf ch (read-char lexer-stream)) 
                          (incf count) 
                          finally (setf match (>= count min))) 
                    (end-of-file () (setf match (>= count min)))) 
                  (when (not match) (loop repeat count do (vector-pop temp-out))) 
                  (values match count)))))) 
 
(defun match-atom-state (ch state lexer-stream temp-out) 
  (case (car state)       
    (:set (values (member ch (rest state) :test #'char=) 0 nil)) 
    (:char (values (char= ch (second state)) 0 nil)) 
    (:range (values (char<= (second state) ch (third state)) 0 nil)) 
    (:not (multiple-value-bind 
            (val count) (match-state ch (second state)  lexer-stream temp-out t) 
            (values (not val) count)))))