sLispでYコンビネータ

「Yコンビネータも出来ないLisp処理系って処理系として終わってるよね。キモッ!」
と女子大生に言われないように、sLispでYコンビネータを出来るようにしました。
前回アップした似非Lisp処理系からかなり書き換えてます。
とりあえずdefunって結局lambdaだよねってのとlambdaときたらラムダ計算のβ簡約(beta reduction)でしょ！
そんで簡約仕切るまで評価はしないよね、常識的に考えて
という戦略です。

次のemacsの記事はこれの解説にするかな。。
継続の実装はちょっと時間的に無理ぽ

sLispに与えるS式

Y関数がYコンビネータです。Yに再帰させたい関数fact0を与えて階乗の再帰的処理をしています

(defun fact0 (f)
  (lambda (n)
    (if (= n 0)
        1
      (* n (f (- n 1))))))

(defun Y (f)
  ((lambda (x)
     (f (x x)))
   (lambda (x)
     (f (x x)))))

(print ((Y fact0) 8))

計算途中

こんな感じでガリガリβ簡約してくれて最後にfact0の再帰的な結果が！感動しますよまじで。

ret:(= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0)
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:*1
ret:(* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1)))
ret:(if (= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1))))
end of eval-lambda beta-reduction ret:(if (= (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1))))
ret:*2
ret:(* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))
ret:(if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1))))
ret:(lambda (n) (if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))))
end of eval-lambda beta-reduction ret:(lambda (n) (if (= n 0) 1 (* n (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1)))))
ret:(= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0)
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:(x x)
ret:(fact0 (x x))
ret:(lambda (x) (fact0 (x x)))
ret:*3
ret:(* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1)))
ret:(if (= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1))))
end of eval-lambda beta-reduction ret:(if (= (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 0) 1 (* (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) (((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1))))
40320

全ソースコード

(require 'cl)

(setq max-specpdl-size 16384)
(setq max-lisp-eval-depth 9192)

(setq slisp-filename "mylisp.l")

(setq type_list '("(" ")"))
(setq start_paren "(")
(setq end_paren ")")
(setq double_quote "\"")
(setq ignore_list '("\t" "\r" "\n" " "))

(setq primitive-list
      '("list" "setq" "let" "defun"
        "if" "cond" "lambda" "apply"
        "progn" "quote" "print"
        "+" "-" "*" "/" "=" ">" "<"
        "not" "or" "and"))
(setq sequence-symbol "progn")

(setq environment (make-hash-table :test #'equal))


(defun gethash-keys (hash)
  (loop for k being the hash-keys in hash collect k))

(defun slisp-copy-hash (srcenv destenv)
  (dolist (key (gethash-keys srcenv))
    (if (eq (gethash key destenv) nil)
        (puthash key (gethash key srcenv) destenv))))

(defun slisp-clear-messages ()
  (let ((buffer (get-buffer "*Messages*"))
        (cur (current-buffer)))
    (progn
      (set-buffer buffer)
      (erase-buffer)
      (switch-to-buffer cur))))

(defun slisp-contains (x list)
  (loop for y in list
        thereis (equal x y)))

(defun slisp-get-src-string (filename)
  (let ((pre-buffer (current-buffer)))
    (find-file filename)
    (setq str (buffer-substring-no-properties (point-min) (point-max)))
    (switch-to-buffer pre-buffer)
    str))

(defmacro slisp-set-tokenbuf-and-clear (buf tokens)
  `(if (not (equal ,buf ""))
       (progn
         (push ,buf ,tokens)
         (setq ,buf ""))))

(defun slisp-get-tokens (in_str)
  (let ((chars (split-string in_str ""))
        (token_buf "")
        (tokens nil)
        (in_double_quote nil))
    (dolist (c chars)
      (if (equal c double_quote)
          (if in_double_quote
              (setq in_double_quote nil)
            (setq in_double_quote t)))
      (cond ((slisp-contains c type_list)
             (progn
               (slisp-set-tokenbuf-and-clear token_buf tokens)
               (push c tokens)))
            ((and (not in_double_quote) (slisp-contains c ignore_list))
             (slisp-set-tokenbuf-and-clear token_buf tokens))
            (t
             (setq token_buf (concat token_buf c)))))
    (nreverse tokens)))

(defun slisp-check-primitive (token)
  (slisp-contains token primitive-list))

(defun slisp-check-type (token type)
  (cond ((equal type "string") (string-match "^\"\\(.+\\)\"$" token))
        ((equal type "number") (string-match "^\\([0-9]+\\)$" token))
        ((equal type "symbol") (string-match "\\\w+" token))
        ((equal type "quote") (string-match "\'.+" token))))

(defun slisp-parse (tokens)
  (let ((stack '()))
    (dolist (token tokens)
      (cond ((equal token start_paren)
             (push '() stack))
            ((equal token end_paren)
             (let* ((cur_stack (pop stack))
                    (up_stack (pop stack)))
               (push
                (cons (nreverse cur_stack) up_stack)
                stack)))
            ((slisp-check-primitive token)
             (push (cons token (pop stack)) stack))
            ((slisp-check-type token "string")
             (push (cons (match-string 1 token) (pop stack)) stack))
            ((slisp-check-type token "number")
             (push (cons (string-to-number (match-string 1 token)) (pop stack)) stack))
            ((slisp-check-type token "symbol")
             (push (cons (make-symbol token) (pop stack)) stack))
            (t
             (push (cons token (pop stack)) stack))))
    (let ((cur (pop stack)))
      (cons sequence-symbol (nreverse cur)))))

(defmacro slisp-make-primitive? (exp operator)
  `(cond ((listp ,exp)
          (let ((op (car ,exp)))
            (and (string? op)
                 (equal op ,operator))))
         (t
          nil)))

(defun slisp-eval (exp env)
  (defun neq (exp obj)
    (not (eq exp obj)))
  (defun pair? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (second (cadr exp)))
          (and (neq first nil)
               (neq second nil)))
      nil))

  (defun number? (exp)
    (numberp exp))
  (defun string? (exp)
    (stringp exp))
  (defun symbol? (exp)
    (symbolp exp))
  (defun self? (exp)
    (cond ((number? exp) t)
          ((string? exp) t)
          ((booleanp exp) t)))
          ;((and (listp exp) ;; self lambda
          ;      (equal (car exp) "lambda"))
          ; t)))
  (defun variable? (exp)
    (symbolp exp))

  ;; special forms check
  (defun list? (exp)
    (slisp-make-primitive? exp "list"))
  (defun let? (exp)
    (slisp-make-primitive? exp "let"))
  (defun set? (exp)
    (slisp-make-primitive? exp "setq"))
  (defun defun? (exp)
    (slisp-make-primitive? exp "defun"))
  (defun if? (exp)
    (slisp-make-primitive? exp "if"))
  (defun cond? (exp)
    (slisp-make-primitive? exp "cond"))
  (defun lambda? (exp)
    (slisp-make-primitive? exp "lambda"))
  (defun apply? (exp)
    (slisp-make-primitive? exp "apply"))
  (defun progn? (exp)
    (slisp-make-primitive? exp "progn"))
  (defun print? (exp)
    (slisp-make-primitive? exp "print"))
  (defun arithmetic? (exp)
    (let ((op (car exp)))
      (cond ((equal op "+") t)
            ((equal op "-") t)
            ((equal op "*") t)
            ((equal op "/") t)
            ((equal op "=") t)
            ((equal op ">") t)
            ((equal op "<") t)
            ((equal op "not") t)
            ((equal op "or") t)
            ((equal op "and") t)
            (t nil))))

  (defun eval-lambda? (exp)
    (let ((first (car exp))
          (rest (cdr exp)))
      (and (listp first)
           (equal "lambda" (car first))
           (not (eq rest nil)))))

  (defun eval-define? (exp)
    (let ((var (car exp)))
      (variable? var)))

  (defun eval-rec-lambda? (exp)
    (if (listp exp)
        (let ((first (car exp))
              (rest (cdr exp)))
          (and (equal first "lambda")
               (neq rest nil)))
      nil))

  (defun application? (exp)
    (pair? exp))

  (defun eval-define (exp env)
    (let* ((func-name (symbol-name (car exp)))
           (func-hash (gethash func-name env))
           (func-args-var (car func-hash))
           (func-body (cadr func-hash))
           (args-length (length func-args-var))
           (func-args-real (cdr exp))
           (new_env (copy-hash-table env)))
      (cond ((eq args-length 0)
             (let ((new_exp (list func-body (list (car func-args-real)))))
               new_exp))
            (t
             (dotimes (i args-length)
               (let ((variable (nth i func-args-var))
                     (value (nth i func-args-real)))
                 (setq exp (beta-reduction exp value (symbol-name variable) env))))
             (slisp-eval exp new_env)))))

  (defun eval-lambda (exp env)
    (let* ((first (car exp))
           (func-args-var (cadr first))
           (func-body (caddr first))
           (func-args-real (cdr exp))
           (args-length (length func-args-var))
           (ret func-body))
      (dotimes (i args-length)
        (let ((variable (nth i func-args-var))
              (value (nth i func-args-real)))
          (setq ret (beta-reduction ret value (symbol-name variable) env))))
      (message "end of eval-lambda beta-reduction ret:%s" ret)
      (slisp-eval ret env)))
  
  (defun eval-self-lambda (exp env)
    (let ((func-args-var (cadr exp))
          (func-body (caddr exp))
          (do_eval nil))
      (dolist (item func-args-var)
        (let ((name (symbol-name item)))
        (if (neq (gethash name env) nil)
            (setq do_eval t))))
      (if do_eval
          (slisp-eval func-body env)
        exp)))

  (defun eval-if (exp env)
    (let ((condition (nth 1 exp))
          (true-body (nth 2 exp))
          (else-body (nth 3 exp)))
      (if (slisp-eval condition (copy-hash-table env))
          (slisp-eval true-body (copy-hash-table env))
        (if (not (eq else-body nil))
            (slisp-eval else-body (copy-hash-table env))))))

  (defun eval-cond (exp env)
    (let ((condlist (cdr exp)))
      (loop for conditem in condlist
            when (slisp-eval (car conditem) (copy-hash-table env))
            return (slisp-eval (cadr conditem) (copy-hash-table env)))))

  (defun make-lambda (exp env)
    (let ((func-name "lambda")
          (func-args (nth 1 exp))
          (func-impl (nth 2 exp)))
      (puthash func-name (list func-args func-impl) env)))

  (defun convert-list (exp)
    (cdr exp))

  (defun set-let (exp env)
    (let ((var-list (cadr exp))
          (exp-list (caddr exp)))
      (dolist (var-item var-list)
        (let ((variable (car var-item))
              (value 
               (cond ((eq (cadr var-item) nil) nil)
                     (t (cadr var-item)))))
          (puthash (symbol-name variable) value env)))
      (slisp-eval exp-list env)))

  (defun set-definition (exp env)
    (let* ((func-name (nth 1 exp))
           (func-args (nth 2 exp))
           (func-impl (nth 3 exp))
           (new_exp (list "lambda" func-args func-impl)))
      (puthash (symbol-name func-name) new_exp env)))

  (defun progn-actions (exp)
    (cdr exp))

  (defun eval-sequence (actions env)
    (dolist (action actions value)
      (setq value (slisp-eval action env))))

  (defun calc (exp env)
    (let ((op (car exp))
          (first (slisp-eval (cadr exp) (copy-hash-table env)))
          (second (slisp-eval (caddr exp) (copy-hash-table env))))
      (cond ((equal op "+") (+ first second))
            ((equal op "-") (- first second))
            ((equal op "*") (* first second))
            ((equal op "/") (/ first second))
            ((equal op "=") (= first second))
            ((equal op "<") (< first second))
            ((equal op ">") (> first second))
            ((equal op "not") (not first))
            ((equal op "or") (or first second))
            ((equal op "and") (and first second)))))

  (defun print (exp env)
    (let ((mes (slisp-eval (cadr exp) (copy-hash-table env))))
      (cond ((number? mes)
             (message "%d" mes))
            ((booleanp mes)
             (if mes (message "t")
               (message "nil")))
            (t
             (message "%s" mes)))))

  (defun lookup-variable-value (exp env)
    (let* ((symbolname (symbol-name exp)))
      (gethash symbolname env)))

  (defun set-assignment (exp env)
    (let ((variable (cadr exp))  
          (value (slisp-eval (caddr exp) (copy-hash-table env))))
      (puthash (symbol-name variable) value env)))

  (defun list-of-values (exp env)
    exp)

  (defun beta-reduction (exp trans_exp key env)
    (let ((ret '())
          (check_exp exp)
          (have_key nil))
      (cond ((lambda? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t))))))
            ((let? check_exp)
             (progn
               (setq check_exp (cddr exp))
               (let ((func-args (cdr check_exp)))
                 (dolist (arg func-args)
                   (if (and (not (listp arg))
                            (equal (symbol-name arg) key))
                       (setq have_key t)))))))
      (if (eq have_key t)
          exp
        (if (listp check_exp)
            (let ((len (length check_exp)))
              (dolist (i check_exp)
                (if (listp i)
                    (let ((in_exp (beta-reduction i trans_exp key env)))
                      (if (= len 1)
                          (setq ret in_exp)
                        (setq ret (cons in_exp (if (eq ret nil) '() ret)))))
                  (let ((ii (if (symbolp i) (symbol-name i) i)))
                    (if (= len 1)
                        (setq ret (if (equal ii key) trans_exp i))
                      (setq ret (cons
                                 (if (equal ii key)
                                     trans_exp
                                   i)
                                 (if (eq ret nil) '() ret))))))))
          (setq ret (cons
                     (if (eq (symbol-name check_exp) key)
                         trans_exp
                       check_exp)
                     ret)))
        (if (> (length check_exp) 1)
            (setq ret (nreverse ret)))
        (cond ((lambda? exp)
               (setq ret (list "lambda" (cadr exp) ret)))
              ((let? exp)
               (setq ret (list "let" (cadr exp) ret))))
        (message "ret:%s" ret)
        ret)))

  (defun eval-apply (exp env)
    (let* ((first (car exp))
           (second (cdr exp))
           (procedure (slisp-eval first env)))
      (let ((new_exp (cons procedure second)))
        (cond ((eval-lambda? new_exp)
               (eval-lambda new_exp env))
              ((eval-define? new_exp)
               (eval-define new_exp env))
              (t
               (error "eval-apply not match:%s" new_exp))))))

  (cond ((self? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((list? exp) (convert-list exp))
        ((let? exp) (set-let exp env))
        ((set? exp) (set-assignment exp env))
        ((defun? exp) (set-definition exp env))
        ((if? exp) (eval-if exp env))
        ((cond? exp) (eval-cond exp env))
        ((lambda? exp)
         (eval-self-lambda exp env))
        ((progn? exp) (eval-sequence (progn-actions exp) env))
        ((arithmetic? exp) (calc exp env))
        ((print? exp) (print exp env))
        ((application? exp)
         (eval-apply exp env))
        ;(t exp)))
        (t (error "Unknown expression type. " exp))))

(slisp-clear-messages)
(slisp-eval (slisp-parse (slisp-get-tokens (slisp-get-src-string slisp-filename))) environment)

*1:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1

*2:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(fact0 ((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x))))) end of eval-lambda beta-reduction ret:(fact0 ((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x))))) ret:(= n 0) ret:(- n 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- n 1

*3:lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) ret:(- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1) ret:(((lambda (x) (fact0 (x x))) (lambda (x) (fact0 (x x)))) (- (- (- (- (- (- (- (- (- 8 1) 1) 1) 1) 1) 1) 1) 1) 1