What is a Project Index?

function · lot

(fold-left f init ())      = init
(fold-left f init (a . d)) = (fold-left f (f init a) d)
(defun fold-left (f init list)
  (if (null list)
      init
      (fold-left f (funcall f init (car list)) (cdr list))))
(defun fold-left (f init list)
  (if (null list)
      init
      (fold-left-1 f init (car list) (cdr list))))

(defun fold-left-1 (f init head tail)
  (if (null tail)
      (funcall f init head)
      (fold-left-1 f (funcall f init head) (car tail) (cdr tail))))
[64919121   -159018721]
[41869520.5 -102558961]
(defun mxv (a b
            c d

            x
            y

            receiver)
  (funcall receiver
           (+ (* a x) (* b y))
           (+ (* c x) (* d y))))

* (mxv 64919121     -159018721
       41869520.5d0 -102558961

       3
       1

       #'list)

(35738642 2.30496005d7)
(defun m-inverse (a b
                  c d

                  receiver)
  (let ((det (- (* a d) (* b c))))
    (funcall receiver
             (/ d det) (/ (- b) det)
             (/ (- c) det) (/ a det))))
(defun solve (a b
              c d

              x
              y

              receiver)
  (m-inverse a b
             c d
             (lambda (ia ib
                      ic id)
               (mxv ia ib
                    ic id

                    x
                    y
                    receiver))))
* (solve 64919121     -159018721
         41869520.5d0 -102558961

         1
         0
         #'list)

(1.02558961d8 4.18695205d7)
* (solve 64919121         -159018721
         (+ 41869520 1/2) -102558961

         1
         0
         #'list)

(205117922 83739041)
(fold-left function init list)
* (fold-left (lambda (l r) `(f ,l ,r)) 'init '(a b c))
(F (F (F INIT A) B) C)
(fold-right function init list)
* (fold-right (lambda (l r) `(f ,l ,r)) 'init '(a b c))
(F A (F B (F C INIT)))
; (fold-right function list final)
* (fold-right (lambda (l r) `(f ,l ,r)) '(a b c) 'final)
(F A (F B (F C FINAL)))
(defclass boring-class ()
  ((a :initarg :a :initform 'a :accessor a)
   (b :initarg :b :initform 'b :accessor b)
   (c :initarg :c :initform 'c :accessor c))
  (:default-initargs :c 'the-c))

(defmethod print-object ((instance boring-class) stream)
  (print-unreadable-object (instance stream :type nil :identity nil)
    (format stream "~a, ~a, ~a" (a instance) (b instance) (c instance))))
(defvar *boring-instance* (make-instance 'boring-class :b 'the-b))
(print *boring-instance*) ;;; #<A, THE-B, THE-C>
(defclass boring-class ()
  ((a :initarg :a :initform 'the-a :accessor a)
   (b :initarg :b :initform 'b :accessor b)
   (c :initarg :c :initform 'c :accessor c))
  (:default-initargs :c 'the-c))

(print *boring-instance*) ;;; #<A, THE-B, THE-C>
(defclass boring-class ()
  ((X :initarg :a :initform 'new-a :accessor a)
   (Y :initarg :b :initform 'b :accessor b)
   (Z :initarg :c :initform 'new-c :accessor c))
  (:default-initargs :b 'new-b))

(print *boring-instance*) ;;; #<NEW-A, NEW-B, NEW-C>
(defclass boring-class ()
  ((#.(gensym) :initarg :a :initform (random 42) :accessor a)
   (#.(gensym) :initarg :b :initform (random 42) :accessor b)
   (#.(gensym) :initarg :c :initform (random 42) :accessor c)))

(print *boring-instance*) ;;; #<15, 13, 18>
;; recompile defclass
(print *boring-instance*) ;;; #<3, 4, 38>
;; recompile defclass
(print *boring-instance*) ;;; #<32, 12, 10>
(defclass boring-class ()
  ((#:a :initarg :a :initform (random 42) :accessor a)
   (#:b :initarg :b :initform (random 42) :accessor b)
   (#:c :initarg :c :initform (random 42) :accessor c)))
;; If factorial = (g (g (g (g … )))), then
;; factorial = (g factorial), where

(defun g (factorial)
  (lambda (x)
    (if (zerop x)
        1
        (* x (funcall factorial (- x 1))))))
;; Non working y operator
(defun y (g)
  (let ((d (lambda (f) (funcall g (funcall f f)))))
    (funcall d d)))
;; Call-by-value y operator
;; returns (g (lambda () (g (lambda () (g (lambda () … ))))))
(defun y (g)
  (let ((d (lambda (f) (funcall g (lambda () (funcall f f))))))
    (funcall d d)))
* (funcall (Y (lambda (thunk)
                (lambda (x)
                  (if (zerop x)
                      1
                      (* x (funcall (funcall thunk) (- x 1)))))))
           6)
720
* (funcall
    (y (lambda (thunk)
         (flet ((factorial (&rest args)
                  (apply (funcall thunk) args)))

           (lambda (x)
             (if (zerop x)
                 1
                 (* x (factorial (- x 1))))))))
      6)
720
(defun y1 (g)
  (let ((d (lambda (f) (funcall g (lambda (&rest args) (apply (funcall f f) args))))))
    (funcall d d)))

* (funcall
    (y1 (lambda (factorial)
          (lambda (x)           
            (if (zerop x)
                1
                (* x (funcall factorial x))))))
    6)
720
(Y
  (lambda (delayed-ones)
    (cons-stream 1 (delayed-ones))))
{1 …}
* (funcall (Y (lambda (thunk)
                (format t "~%Returning a procedure")
                (lambda (x)
                  (if (zerop x)
                      1
                      (* x (funcall (funcall thunk) (- x 1)))))))
         6)
Returning a procedure
Returning a procedure
Returning a procedure
Returning a procedure
Returning a procedure
Returning a procedure
720
(Y (lambda (thunk)
     (h (lambda (x)
          (if (zerop x)
              1
              … )))))
(y (lambda (thunk)
      (h (lambda (x)
           (if (zerop x)
               1
               (* (funcall (h^-1 (funcall thunk)) (- x 1))))))))
* (funcall (car (y (lambda (thunk)
                     (list (lambda (x)
                             (if (zerop x)
                                 1
                                 (* x (funcall (car (funcall thunk)) (- x 1))))))))
           6)
720
(y (lambda (thunk)
    (list
      ;; even?
      (lambda (n)
        (or (zerop n)
            (funcall (cadr (funcall thunk)) (- n 1))))

      ;; odd?
      (lambda (n)
        (and (not (zerop n))
             (funcall (car (funcall thunk)) (- n 1))))
      )))
(defun y* (&rest g-list)
  (let ((d (lambda (f)
             (map 'list (lambda (g)
                          (lambda (&rest args)
                            (apply (apply g (funcall f f)) args)))
                  g-list))))
     (funcall d d)))
* (let ((eo (y* (lambda (even? odd?)
                  (declare (ignore even?))
                  (lambda (n)
                    (or (zerop n)
                        (funcall odd? (- n 1)))))

                (lambda (even? odd?)
                  (declare (ignore odd?))
                  (lambda (n)
                    (and (not (zerop n))
                         (funcall even? (- n 1))))))))
     (let ((even? (car eo))
           (odd?  (cadr eo)))
       (do ((i 0 (+ i 1)))
           ((>= i 5))
         (format t "~%~d, ~s ~s"
                 i
                 (funcall even? i)
                 (funcall odd? i)))))))

0, T NIL
1, NIL T
2, T NIL
3, NIL T
4, T NIL
(defun y* (&rest gs)
  (let ((d (lambda (f)
             (apply #'values
                    (map 'list
                         (lambda (g)
                           (lambda (&rest args)
                             (apply (multiple-value-call g (funcall f f)) args)))
                         gs)))))
    (funcall d d)))
(defmacro named-lambda ((name &rest args) &body body)
  `(y1 (lambda (,name)
         (lambda ,args
           ,@body))))

* (funcall (named-lambda (factorial x)
            (if (zerop x)
                1
                (* x (funcall factorial (- x 1)))))
         6)
720
* (named-let fact ((x 6)) (if (zerop x) 1 (* x (funcall fact (- x 1)))))

720
(defun beta (expression if-reduced if-not-reduced)
  (if (application? expression)
      (let ((operator (application-operator expression))
            (operands (application-operands expression)))
        (if (lambda? operator)
            (let ((bound-variables (lambda-bound-variables operator))
                  (body (lambda-body operator)))
              (if (same-length? bound-variables operands)
                  (funcall if-reduced
                           (xsubst body
                                   (table/extend* (table/empty)
                                                  bound-variables
                                                  operands)))
                  (funcall if-not-reduced)))
            (funcall if-not-reduced)))
      (funcall if-not-reduced)))

* (beta '((lambda (x y) (lambda (z) (* x y z))) a (+ z 3))
        #'identity (constantly nil))
(LAMBDA (#:Z460) (* A (+ Z 3) #:Z460))
(defun beta-normalize-step (expression)
  (expression-dispatch expression

    ;; case application
    (lambda (subexpressions)
      ;; Normal order reduction
      ;; First, try to beta reduce the outermost application,
      ;; otherwise, recursively descend the subexpressions, working
      ;; from left to right.
      (beta expression
            #'identity
            (lambda ()
              (labels ((l (subexpressions)
                         (if (null subexpressions)
                             '()
                             (let ((new-sub (beta-normalize-step (car subexpressions))))
                               (if (eq new-sub (car subexpressions))
                                   (let ((new-tail (l (cdr subexpressions))))
                                     (if (eq new-tail (cdr subexpressions))
                                         subexpressions
                                         (cons (car subexpressions) new-tail)))
                                   (cons new-sub (cdr subexpressions)))))))
                (let ((new-subexpressions (l subexpressions)))
                  (if (eq new-subexpressions subexpressions)
                      expression
                      (make-application new-subexpressions)))))))

    ;; case lambda
    (lambda (bound-variables body)
      (let ((new-body (beta-normalize-step body)))
        (if (eql new-body body)
            expression
            (make-lambda bound-variables new-body))))

    ;; case symbol
    (constantly expression)))

;;; A normalized expression is a fixed point of the
;;; beta-normalize-step function.
(defun beta-normalize (expression)
  (do ((expression expression (beta-normalize-step expression))
       (expression1 '() expression)
       (count 0 (+ count 1)))
      ((eq expression expression1)
       (format t "~%~d beta reductions" (- count 1))
       expression)))
(defun test-form ()
  (let ((table
         (table/extend*
          (table/empty)
          '(one
            three
            *
            pred
            zero?
            y)
          '(
            ;; Church numeral one
            (lambda (f) (lambda (x) (f x)))

            ;; Church numeral three 
            (lambda (f) (lambda (x) (f (f (f x)))))

            ;; * (multiply Church numerals)
            (lambda (m n)
              (lambda (f)
                (m (n f))))

            ;; pred (subtract 1 from Church numeral)
            (lambda (n)
              (lambda (f)
                (lambda (x) (((n (lambda (g)
                                   (lambda (h)
                                     (h (g f)))))
                              (lambda (u) x))
                             (lambda (u) u)))))

            ;; zero? (test if Church numeral is zero)
            (lambda (n t f) ((n (lambda (x) f)) t))

            ;; Y operator for recursion
            (lambda (f)
              ((lambda (x) (f (x x)))
               (lambda (x) (f (x x)))))

            )))
        (expr
         '((lambda (factorial)
             (factorial three))
           (y (lambda (fact)
                (lambda (x)
                  (zero? x
                   one
                   (* (fact (pred x)) x))))))))
    (xsubst expr table)))

* (test-form)

((LAMBDA (FACTORIAL) (FACTORIAL (LAMBDA (F) (LAMBDA (X) (F (F (F X)))))))
 ((LAMBDA (F) ((LAMBDA (X) (F (X X))) (LAMBDA (X) (F (X X)))))
  (LAMBDA (FACT)
    (LAMBDA (X)
      ((LAMBDA (N T F) ((N (LAMBDA (X) F)) T)) X
       (LAMBDA (F) (LAMBDA (X) (F X)))
       ((LAMBDA (M N) (LAMBDA (F) (M (N F))))
        (FACT
         ((LAMBDA (N)
            (LAMBDA (F)
              (LAMBDA (X)
                (((N (LAMBDA (G) (LAMBDA (H) (H (G F))))) (LAMBDA (U) X))
                 (LAMBDA (U) U)))))
          X))
        X))))))

* (beta-normalize (test-form))

127 beta reductions
(LAMBDA (F) (LAMBDA (X) (F (F (F (F (F (F X))))))))
CL-USER> (ql:quickload '("mcclim" "alexandria" "hunchentoot" "local-time"))
("mcclim" "alexandria" "hunchentoot" "local-time")
CL-USER> (defpackage #:eu.turtleware.dimwit
           (:use #:clim-lisp)
           (:local-nicknames (#:m #:clim)
                             (#:e #:clim-extensions)
                             (#:b #:clim-backend)
                             (#:a #:alexandria)
                             (#:t #:local-time)
                             (#:h #:hunchentoot)))
#<PACKAGE "EU.TURTLEWARE.DIMWIT">
CL-USER> (in-package #:eu.turtleware.dimwit)
#<PACKAGE "EU.TURTLEWARE.DIMWIT">
DIMWIT>

DIMWIT> (m:region-intersection (m:make-rectangle* 0 0 100 100)
                               (m:make-rectangle* 50 50 200 200)) 
#<M:STANDARD-BOUNDING-RECTANGLE X 50:100 Y 50:100>

DIMWIT> (m:presentation-typep '(1 2 3 4) '(sequence integer)) ; -> T
DIMWIT> (m:presentation-typep '(1 2 3 t) '(sequence integer)) ; -> NIL

(defclass darts-circle (m:basic-output-record)
  ((points
    :initarg :points
    :reader points)
   (radius
    :initarg :radius
    :reader radius)))

(defmethod m:output-record-refined-position-test ((record darts-circle) x y)
  (let ((r (radius record)))
    (m:region-contains-position-p (m:make-ellipse* 0 0 r 0 0 r) x y)))

(defun make-dart-circle (points radius)
  (let ((-radius (- radius)))
    (make-instance 'darts-circle :points points :radius radius
                                 :x1 -radius :y1 -radius
                                 :x2  radius :y2  radius)))

(defclass dart (m:basic-output-record) ())

(defun make-dart (x y)
  (make-instance 'dart :x-position x :y-position y))

(defun make-board (number-of-circles)
  (check-type number-of-circles (integer 1))
  (loop with board = (make-instance 'm:standard-tree-output-record)
        for circle from number-of-circles above 0
        for points from 10 by 10
        for radius = (* circle 10)
        for record = (make-dart-circle points radius)
        do (m:add-output-record record board)
        finally (return board)))

(defun throw-dart (board x y &aux (robin nil))
  (m:map-over-output-records-containing-position
   (lambda (record)
     (etypecase record
       (darts-circle
        (let ((points (points record)))
          (format t "~d points!~%" points)
          (when (null robin)
            (m:add-output-record (make-dart x y) board))
          (return-from throw-dart points)))
       (dart
        (format t "Uh oh, we have a Robin Hood! ~a.~%" record)
        (setf robin t))))
   board x y)
  (m:add-output-record (make-dart x y) board)
  (format t "Phew.~%")
  0)

(defun remove-darts (board)
  (let ((to-remove '()))
    (m:map-over-output-records
     (lambda (record)
       (when (typep record 'dart)
         (push record to-remove)))
     board)
    (map () (a:rcurry #'m:delete-output-record board) to-remove)))

(m:define-command-table default-command-table)

(m:define-command (com-get-time :command-table default-command-table :name t)
    ()
  (t:format-rfc1123-timestring t (t:now)))

(m:define-command (com-echo :command-table default-command-table :name t)
    ((string 'string))
  (format t "~a" string))

(m:define-command (com-eval :command-table default-command-table :name t)
    ((expression 'm:expression))
  (eval expression))

DIMWIT> (com-get-time)
Fri, 14 May 2021 14:48:54 +0200
"Fri, 14 May 2021 14:48:54 +0200"
DIMWIT> (com-eval '(print "Yo ho and a bottle of rum."))
"Yo ho and a bottle of rum." 
"Yo ho and a bottle of rum."
DIMWIT> (com-echo "Yo ho and two bottles of rum.")
Yo ho and two bottles of rum.
NIL   

(defun simple-repl (ct &optional (prompt (m:command-table-name ct))
                    &aux (* nil))
  (labels ((list-commands ()
             (format t "Commands in ~a:~%" ct)
             (m:map-over-command-table-commands #'print ct))
           (assert-command (command)
             (when (eq command 'help)
               (list-commands)
               (return-from assert-command `(climi::com-null-command)))
             (let ((name (car command)))
               (unless (symbolp name)
                 (error "~a does not designate a command." name))
               (unless (m:command-accessible-in-command-table-p name ct)
                 (error "Command ~a not found." name))
               command)))
    (loop
      (format t "~&~a> " prompt)
      (handler-case
          (let* ((cmd (assert-command (read)))
                 (results (multiple-value-list (eval cmd))))
            (format t "~&---~%~{~a~%~}" results)
            (setf * (first results)))
        (m:frame-exit ()
          (format t "~&---~%Good Bye!~%")
          (return))
        (serious-condition (c)
          (format t "~&---~%ERROR:~%~a" c))))))

DIMWIT> (simple-repl (m:find-command-table 'default-command-table))

DEFAULT-COMMAND-TABLE> help
Commands in #<STANDARD-COMMAND-TABLE DEFAULT-COMMAND-TABLE {102029B323}>:

COM-GET-TIME 
COM-ECHO 
COM-EVAL 
CLIM-INTERNALS::COM-NULL-COMMAND 
CLIM-INTERNALS::COM-HELP 
CLIM-INTERNALS::COM-QUIT 
CLIM-INTERNALS::COM-DESCRIBE 
CLIM-INTERNALS::COM-DESCRIBE-PRESENTATION 
---
NIL
DEFAULT-COMMAND-TABLE> (com-get-time)
Fri, 14 May 2021 15:33:31 +0200
---
Fri, 14 May 2021 15:33:31 +0200
DEFAULT-COMMAND-TABLE> (com-eval `(list 1 2 3))

---
(1 2 3)
DEFAULT-COMMAND-TABLE> (climi::com-describe *)
1,2,3 is of type CONS
---
DEFAULT-COMMAND-TABLE> (list 1 2 3)

---
ERROR:
Command LIST not found.
DEFAULT-COMMAND-TABLE> (climi::com-quit)

---
Good Bye!
NIL

(m:define-application-frame default-frame () ()
  (:command-table (default-command-table)))
(m:find-application-frame 'default-frame)

(defclass task ()
  ((state
    :type (member :todo :done)
    :initarg :state
    :accessor state)
   (title
    :type string
    :initarg :title
    :accessor title)))

(defclass textual-view-with-colors (m:textual-view) ())
(defconstant +textual-view-with-colors+
  (make-instance 'textual-view-with-colors))

(m:define-presentation-method m:present
    (object (type task) stream (view m:textual-view) &key)
  (format stream "[~s | ~a]" (state object) (title object)))

(m:define-presentation-method m:present
    (object (type task) stream (view textual-view-with-colors) &key)
  (m:with-drawing-options (stream :ink (ecase (state object)
                                         (:done m:+dark-green+)
                                         (:todo m:+dark-red+)))
    (format stream "~a " (state object)))
  (format stream "| ~a" (title object)))

(m:define-application-frame todo-list ()
  ((tasks :initarg :tasks :accessor tasks))
  (:panes (int :interactor
               :default-view +textual-view-with-colors+
               :text-margins '(:left 5 :top 3))
          (app :application
               :default-view +textual-view-with-colors+
               :text-margins '(:left 10 :top 5)
               :display-function (lambda (frame stream)
                                   (declare (ignore frame stream))
                                   (show-tasks))))
  (:layouts (default (m:vertically () app int)))
  (:command-table (todo-list :inherit-from (default-command-table)))
  (:default-initargs :tasks nil))

(define-todo-list-command (add-task :name t)
    ((title 'string))
  (push (make-instance 'task :title title :state :todo)
        (tasks m:*application-frame*)))

(define-todo-list-command (delete-task :name t)
    ((task 'task))
  (let ((frame m:*application-frame*))
    (setf (tasks frame) (remove task (tasks frame)))))

(define-todo-list-command (change-state :name t)
    ((task 'task))
  (setf (state task)
        (ecase (state task)
          (:done :todo)
          (:todo :done))))

(define-todo-list-command (show-tasks :name t)
    ()
  (m:format-textual-list
   (tasks m:*application-frame*)
   (lambda (object stream)
     (m:present object 'task :stream stream))
   :separator #\newline))

(m:define-presentation-to-command-translator click-change-state
    (task change-state todo-list)
    (object)
  (list object))

(defun command-loop (frame)
  (let ((m:*application-frame* frame)
        (ct (m:frame-command-table frame)))
    (simple-repl ct)))

(defparameter *todo-list* (m:find-application-frame 'todo-list))

(command-loop *todo-list*)

(m:define-application-frame proxy-frame-manager
    (e:headless-frame-manager m:standard-application-frame)
  ((frames
    :initform nil
    :accessor frames
    :reader m:frame-manager-frames)
   (destination-frame-manager
    :initarg :frame-manager
    :reader frame-manager))
  (:command-table (frame-manager :inherit-from (default-command-table)))
  (:default-initargs :port '#:port
                     :frame-manager (m:find-frame-manager)))

(defmethod m:adopt-frame ((fm proxy-frame-manager) frame)
  (pushnew frame (frames fm))
  (m:adopt-frame (frame-manager fm) frame))

(defmethod m:disown-frame ((fm proxy-frame-manager) frame)
  (a:removef (frames fm) frame)
  (m:disown-frame (frame-manager fm) frame))

(define-proxy-frame-manager-command (make-frame :name t)
    ((frame 'symbol))
  (adopt-frame (m:make-application-frame frame)))

(define-proxy-frame-manager-command (adopt-frame :name t)
    ((frame 'clim:application-frame))
  (m:adopt-frame m:*application-frame* frame))

(define-proxy-frame-manager-command (disown-frame :name t)
    ((frame 'clim:application-frame))
  (m:disown-frame m:*application-frame* frame))

(define-proxy-frame-manager-command (enter-frame :name t)
    ((frame 'clim:application-frame))
  (command-loop frame))

(define-proxy-frame-manager-command (start-frame :name t)
    ((frame 'clim:application-frame))
  (clim-sys:make-process (lambda () (m:run-frame-top-level frame))))

(define-proxy-frame-manager-command (show-frames :name t) ()
  (let ((frames (m:frame-manager-frames m:*application-frame*)))
    (dolist (frame frames)
      (m:present frame)
      (terpri))
    frames))

(command-loop (m:make-application-frame 'frame-manager))

(defun expression-dispatch (expression if-symbol if-application)
  (cond ((symbolp expression) (funcall if-symbol expression))
        ((consp expression)   (funcall if-application expression))
        (t (error "~s is not an expression." expression))))
(defun xsubst (table expression)
  (expression-dispatch expression
    (lambda (symbol)
      (funcall table symbol #'identity (constantly symbol)))

    (lambda (subexpressions)
      (map 'list (lambda (subexpression) (xsubst table subexpression)) subexpressions))))

* (let ((table (table/extend (table/empty) 'x '(* a 42))))
    (xsubst table '(+ x y)))  
(+ (* A 42) Y)
* (let ((table (table/extend
                 (table/extend (table/empty) 'x 'y)
                 'y 'x)))
    (xsubst table '(+ x y)))
(+ Y X)
(defun expression-dispatch (expression if-symbol if-lambda if-application) 
  (cond ((symbolp expression) (funcall if-symbol expression))
        ((consp expression)
         (cond ((eq (car expression) 'lambda)
                (funcall if-lambda (cadr expression) (caddr expression)))
               (t (funcall if-application expression))))
        (t (error "~s is not an expression." expression))))
(defun free-variables (expression)
   (expression-dispatch expression
     (lambda (symbol) (list symbol))
     (lambda (bound-variables body)
       (set-difference (free-variables body) bound-variables))
     (lambda (subexpressions)
       (fold-left #'union '() (map 'list #'free-variables subexpressions)))))
(map 'list (lambda (var)
             (funcall table var #'free-variables (constantly '())))
      (free-variables expression))
(fold-left #'union '()
           (map 'list (lambda (var)
                        (funcall table var #'free-variables (constantly '())))
                 (free-variables expression)))

(intersection 
  bound-variables
  (fold-left #'union '()
             (map 'list (lambda (var)
                          (funcall table var #'free-variables (constantly '())))
                  (free-variables expression))))
(defun make-alpha-table (variables)
  (fold-left (lambda (table variable)
               (table/extend table variable (gensym (symbol-name variable))))
             (table/empty)
             variables))

(let ((alpha-table
       (make-alpha-table
        (intersection 
          bound-variables
          (fold-left #'union '()
                     (map 'list (lambda (var)
                                  (funcall table var #'free-variables (constantly '())))
                          (free-variables expression)))))))
  …)
  (make-lambda
    (map 'list (lambda (symbol)
                 (funcall alpha-table symbol #'identity (constantly symbol)))
         bound-variables)
    …)
  (make-lambda
   (map 'list (lambda (symbol)
                (funcall alpha-table symbol #'identity (constantly symbol)))
        bound-variables)
   (xsubst (table/append alpha-table (table/redact* table bound-variables))
           body))))
(defun xsubst (table expression)
  (expression-dispatch expression
    (lambda (symbol)
      (funcall table symbol #'identity (constantly symbol)))

    (lambda (bound-variables body)
      (let ((alpha-table
             (make-alpha-table
              (intersection
               bound-variables
               (fold-left #'union '()
                          (map 'list (lambda (var)
                                       (funcall table var
                                                #'free-variables
                                                (constantly '())))
                               (set-difference (free-variables body) bound-variables)))))))
        (make-lambda
         (map 'list (lambda (symbol)
                      (funcall alpha-table symbol #'identity (constantly symbol)))
              bound-variables)
         (xsubst (table/append alpha-table (table/redact* table bound-variables))
                 body))))

    (lambda (subexpressions)
      (make-application
       (map 'list (lambda (subexpression)
                    (xsubst table subexpression))
            subexpressions)))))
* (xsubst (table/extend (table/empty) 'x '(* a y)) '(lambda (y) (+ x y)))
(LAMBDA (#:Y234) (+ (* A Y) #:Y234))
lookup (key if-found if-not-found)

    Invokes (funcall if-found value) if key is in the table,
    invokes (funcall if-not-found) otherwise.
(defun table/empty ()
  (lambda (key if-found if-not-found)
    (declare (ignore key if-found))
    (funcall if-not-found)))
(defun table/extend (table key* value)
  (lambda (key if-found if-not-found)
    (if (eql key key*)
        (funcall if-found value)
        (funcall table key if-found if-not-found))))
(defvar *table-1* (table/extend 
                    (table/extend
                      (table/empty)
                      'foo 42)
                    'bar 69))

* (funcall *table-1* 'foo #'identity (constantly 'not-found))
42

* (funcall *table-1* 'quux #'identity (constantly 'not-found))
NOT-FOUND
(defun table/redact (table redacted)
  (lambda (key if-found if-not-found)
    (if (eql key redacted)
        (funcall if-not-found)
        (funcall table key if-found if-not-found))))

(defvar *table-2* (table/redact *table-1* 'foo))

* (funcall *table-2* 'foo #'identity (constantly 'not-found))
NOT-FOUND
(defun table/bind-predicate (table predicate value)
  (lambda (key if-found if-not-found)
    (if (funcall predicate key)
        (funcall if-found value)
        (funcall table key if-found if-not-found))))

;;; bind all even numbers to the symbol 'EVEN
(defvar *table-3* 
  (table/bind-predicate *table-2* (lambda (n) (and (numberp n) (evenp n))) 'even))

* (funcall *table-3* 6 #'identity (constantly 'not-found))
EVEN
(defun table/add-default (table default-value)
  (lambda (key if-found if-not-found)
    (declare (ignore if-not-found))
    (funcall table key
      if-found
      (lambda () (funcall if-found default-value)))))

(defvar *table-4* (table/add-default *table-3* 'default))

* (funcall *table-4* 'bar #'identity (constantly 'not-found))
69

* (funcall *table-4* 'xyzzy #'identity (constantly 'not-found))
DEFAULT
* *table-4*
#<CLOSURE (LAMBDA (KEY IF-FOUND IF-NOT-FOUND) :IN TABLE/ADD-DEFAULT) {1003CD641B}>
(defun ping ()
  (let (proc out exit-code)
    (unwind-protect
         (progn
           (setf proc (uiop:launch-program
                       (list "ping" "-c" "5" "www.darkchestnut.com")
                       :ignore-error-status t
                       :output :stream))
           (setf out (uiop:process-info-output proc))
           (iter
             (while (uiop:process-alive-p proc))
             (iter
               (while (listen out))
               (write-char (read-char out) *STANDARD-OUTPUT*))
             ;; ... Maybe do something here
             (sleep 0.5))
           (uiop:copy-stream-to-stream out *STANDARD-OUTPUT* 
                                       :linewise t))
      (setf exit-code (uiop:wait-process proc))
      (uiop:close-streams proc))
    exit-code))

(defun ping-processing ()
  (let (proc out exit-code output)
    (with-open-stream (output-stream (make-string-output-stream))
      (with-open-stream (broadcast-stream 
                         (make-broadcast-stream *STANDARD-OUTPUT* 
                                                output-stream))
        (unwind-protect
             (progn
               (setf proc (uiop:launch-program
                           (list "ping" "-c" "5" 
                                 "www.darkchestnut.com")
                           :ignore-error-status t
                           :output :stream))
               (setf out (uiop:process-info-output proc))
               (iter
                 (while (uiop:process-alive-p proc))
                 (iter
                   (while (listen out))
                   (write-char (read-char out) broadcast-stream))
                 (sleep 0.5))
               (uiop:copy-stream-to-stream out broadcast-stream 
                                           :linewise t)))
          (setf exit-code (uiop:wait-process proc))
          (uiop:close-streams proc)
        (setf output (get-output-stream-string output-stream))
        ;; ... process output here
        exit-code))))

k_bar = (lambda (return-value)
         (k_foo (finish-foo return-value)))
k_bar = (lambda (return-value)
         (k_foo return-value))

Related Sites

Archives

Subscriptions

Nicolas Hafner — Patch update, holidays, and the GIC - October Kandria Update

Kandria Patch Update

Holidays

Game Industry Conference

Tim

Fred & Mikel

Roadmap

Eric Timmons — New Project: cl-tar

cl-tar-file

cl-tar

next steps

Eric Timmons — CLPM 0.4.0 released

Nicolas Hafner — 0.2.2 Demo Release, Gamescom & more - September Kandria Update

0.2.2 Demo Release

Pro Helvetia Grant

Gamescom, Devcom, IndieArenaBooth

UI

Tim

Fred

Mikel

Cai

Roadmap

Eric Timmons — Toward a New CL Project Index

What is a Project Index?

Quicklisp Issues

Ultralisp

CLPI

Conflation of project manager and project index

The project index format is not documented

Not a lot of data is provided

Not easily extensible

Enforces a particular style of development

Takes control of releases away from developers

The index is not space efficient

Next Steps

Eric Timmons — CLPM 0.4.0-rc.1 Available

Joe Marshall — Tail recursion and fold-left

Joe Marshall — A Floating-point Problem

Joe Marshall — Fold right

Quicklisp news — August 2021 Quicklisp dist update now available

Nicolas Hafner — GDC, fighting, and more - August Kandria Update

GDC

Combat developments

UI look and feel

Eternia update

Tim

Fred

Mikel

Cai

Roadmap

Michał Herda — Common Lisp Recipes, 2nd Edition

McCLIM — Progress report #12

Finances and bounties

Improvements

Pending work

Nicolas Hafner — Testing events - July Kandria Update

GDC, Gamescom, and GIC

Marketing

Playtesting

Tutorial

Tim

Mikel

Roadmap

Quicklisp news — June 2021 Quicklisp dist update now available

Nicolas Hafner — Updates Galore - June Kandria Update

The New Trailer

0.1.1 Release

Dev Streams

Palestinian Aid Bundle

Tim

Roadmap

Eric Timmons — ASDF 3.3.5 Release Candidate

Changes

Future

Michał Herda — Current Common Lisp IRC situation

Quicklisp news — May 2021 Quicklisp dist update now available

Pavel Korolev — :claw honing - Beta milestone and alien-works

Joe Marshall — β-conversion

Joe Marshall — η-conversion and tail recursion