March 2014 update
This commit is contained in:
Ingy döt Net
parent
09687c4926
commit
a25938f123
1846 changed files with 21876 additions and 5203 deletions
|
|
@ -1,8 +1,29 @@
|
|||
;; The -> notation is not part of Lisp, it is used in examples indicate the output of a form.
|
||||
;;
|
||||
;;
|
||||
(comprehend 'list-monad (cons x y) (x '(1 2 3)) (y '(A B C)))
|
||||
|
||||
-> ((1 . A) (1 . B) (1 . C)
|
||||
(2 . A) (2 . B) (2 . C)
|
||||
(3 . A) (3 . B) (3 . C))
|
||||
(system::expand-form
|
||||
'(loop for count from 1
|
||||
for x in '(1 2 3 4 5)
|
||||
summing x into sum
|
||||
summing (* x x) into sum-of-squares
|
||||
finally
|
||||
(return
|
||||
(let* ((mean (/ sum count))
|
||||
(spl-var (- (* count sum-of-squares) (* sum sum)))
|
||||
(spl-dev (sqrt (/ spl-var (1- count)))))
|
||||
(values mean spl-var spl-dev))))))
|
||||
(BLOCK NIL
|
||||
(LET ((COUNT 1))
|
||||
(LET ((#:LIST-3230 '(1 2 3 4 5)))
|
||||
(LET ((X NIL))
|
||||
(LET ((SUM-OF-SQUARES 0) (SUM 0))
|
||||
(TAGBODY SYSTEM::BEGIN-LOOP
|
||||
(WHEN (ENDP #:LIST-3230) (GO SYSTEM::END-LOOP))
|
||||
(SETQ X (CAR #:LIST-3230))
|
||||
(PROGN (SETQ SUM (+ SUM X))
|
||||
(SETQ SUM-OF-SQUARES (+ SUM-OF-SQUARES (* X X))))
|
||||
(PSETQ COUNT (+ COUNT 1)) (PSETQ #:LIST-3230 (CDR #:LIST-3230))
|
||||
(GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
|
||||
(RETURN-FROM NIL
|
||||
(LET*
|
||||
((MEAN (/ SUM COUNT))
|
||||
(SPL-VAR (- (* COUNT SUM-OF-SQUARES) (* SUM SUM)))
|
||||
(SPL-DEV (SQRT (/ SPL-VAR (1- COUNT)))))
|
||||
(VALUES MEAN SPL-VAR SPL-DEV)))))))))
|
||||
|
|
|
|||
|
|
@ -1,2 +1,8 @@
|
|||
(identity-comp (list x y z) (x 1) (y (* 3 x)) (z (+ x y)))
|
||||
-> (1 3 4)
|
||||
;; The -> notation is not part of Lisp, it is used in examples indicate the output of a form.
|
||||
;;
|
||||
;;
|
||||
(comprehend 'list-monad (cons x y) (x '(1 2 3)) (y '(A B C)))
|
||||
|
||||
-> ((1 . A) (1 . B) (1 . C)
|
||||
(2 . A) (2 . B) (2 . C)
|
||||
(3 . A) (3 . B) (3 . C))
|
||||
|
|
|
|||
|
|
@ -1,99 +1,2 @@
|
|||
(defgeneric monadic-map (monad-class function))
|
||||
|
||||
(defgeneric monadic-join (monad-class container-of-containers &rest additional))
|
||||
|
||||
(defgeneric monadic-instance (monad-class-name))
|
||||
|
||||
(defmacro comprehend (monad-instance expr &rest clauses)
|
||||
(let ((monad-var (gensym "CLASS-")))
|
||||
(cond
|
||||
((null clauses) `(multiple-value-call #'monadic-unit
|
||||
,monad-instance ,expr))
|
||||
((rest clauses) `(let ((,monad-var ,monad-instance))
|
||||
(multiple-value-call #'monadic-join ,monad-var
|
||||
(comprehend ,monad-var
|
||||
(comprehend ,monad-var ,expr ,@(rest clauses))
|
||||
,(first clauses)))))
|
||||
(t (destructuring-bind (var &rest container-exprs) (first clauses)
|
||||
(cond
|
||||
((and var (symbolp var))
|
||||
`(funcall (monadic-map ,monad-instance (lambda (,var) ,expr))
|
||||
,(first container-exprs)))
|
||||
((and (consp var) (every #'symbolp var))
|
||||
`(multiple-value-call (monadic-map ,monad-instance
|
||||
(lambda (,@var) ,expr))
|
||||
,@container-exprs))
|
||||
(t (error "COMPREHEND: bad variable specification: ~s" vars))))))))
|
||||
|
||||
(defmacro define-monad (class-name
|
||||
&key comprehension
|
||||
(monad-param (gensym "MONAD-"))
|
||||
bases slots initargs
|
||||
((:map ((map-param)
|
||||
&body map-body)))
|
||||
((:join ((join-param
|
||||
&optional
|
||||
(j-rest-kw '&rest)
|
||||
(j-rest (gensym "JOIN-REST-")))
|
||||
&body join-body)))
|
||||
((:unit ((unit-param
|
||||
&optional
|
||||
(u-rest-kw '&rest)
|
||||
(u-rest (gensym "UNIT-REST-")))
|
||||
&body unit-body))))
|
||||
`(progn
|
||||
(defclass ,class-name ,bases ,slots)
|
||||
(defmethod monadic-instance ((monad (eql ',class-name)))
|
||||
(load-time-value (make-instance ',class-name ,@initargs)))
|
||||
(defmethod monadic-map ((,monad-param ,class-name) ,map-param)
|
||||
(declare (ignorable ,monad-param))
|
||||
,@map-body)
|
||||
(defmethod monadic-join ((,monad-param ,class-name)
|
||||
,join-param &rest ,j-rest)
|
||||
(declare (ignorable ,monad-param ,j-rest))
|
||||
,@join-body)
|
||||
(defmethod monadic-unit ((,monad-param ,class-name)
|
||||
,unit-param &rest ,u-rest)
|
||||
(declare (ignorable ,monad-param ,u-rest))
|
||||
,@unit-body)
|
||||
,@(if comprehension
|
||||
`((defmacro ,comprehension (expr &rest clauses)
|
||||
`(comprehend (monadic-instance ',',class-name)
|
||||
,expr ,@clauses))))))
|
||||
|
||||
(defmethod monadic-map ((monad symbol) function)
|
||||
(monadic-map (monadic-instance monad) function))
|
||||
|
||||
(defmethod monadic-join ((monad symbol) container-of-containers &rest rest)
|
||||
(apply #'monadic-join (monadic-instance monad) container-of-containers rest))
|
||||
|
||||
(defmethod monadic-unit ((monad symbol) element &rest rest)
|
||||
(apply #'monadic-unit (monadic-instance monad) element rest))
|
||||
|
||||
(define-monad list-monad
|
||||
:comprehension list-comp
|
||||
:map ((function) (lambda (container) (mapcar function container)))
|
||||
:join ((list-of-lists) (reduce #'append list-of-lists))
|
||||
:unit ((element) (list element)))
|
||||
|
||||
(define-monad identity-monad
|
||||
:comprehension identity-comp
|
||||
:map ((f) f)
|
||||
:join ((x &rest rest) (apply #'values x rest))
|
||||
:unit ((x &rest rest) (apply #'values x rest)))
|
||||
|
||||
(define-monad state-xform-monad
|
||||
:comprehension state-xform-comp
|
||||
:map ((f)
|
||||
(lambda (xformer)
|
||||
(lambda (s)
|
||||
(identity-comp (values (funcall f x) new-state)
|
||||
((x new-state) (funcall xformer s))))))
|
||||
:join ((nested-xformer)
|
||||
(lambda (s)
|
||||
(identity-comp (values x new-state)
|
||||
((embedded-xformer intermediate-state)
|
||||
(funcall nested-xformer s))
|
||||
((x new-state)
|
||||
(funcall embedded-xformer intermediate-state)))))
|
||||
:unit ((x) (lambda (s) (values x s))))
|
||||
(identity-comp (list x y z) (x 1) (y (* 3 x)) (z (+ x y)))
|
||||
-> (1 3 4)
|
||||
|
|
|
|||
99
Task/Metaprogramming/Common-Lisp/metaprogramming-6.lisp
Normal file
99
Task/Metaprogramming/Common-Lisp/metaprogramming-6.lisp
Normal file
|
|
@ -0,0 +1,99 @@
|
|||
(defgeneric monadic-map (monad-class function))
|
||||
|
||||
(defgeneric monadic-join (monad-class container-of-containers &rest additional))
|
||||
|
||||
(defgeneric monadic-instance (monad-class-name))
|
||||
|
||||
(defmacro comprehend (monad-instance expr &rest clauses)
|
||||
(let ((monad-var (gensym "CLASS-")))
|
||||
(cond
|
||||
((null clauses) `(multiple-value-call #'monadic-unit
|
||||
,monad-instance ,expr))
|
||||
((rest clauses) `(let ((,monad-var ,monad-instance))
|
||||
(multiple-value-call #'monadic-join ,monad-var
|
||||
(comprehend ,monad-var
|
||||
(comprehend ,monad-var ,expr ,@(rest clauses))
|
||||
,(first clauses)))))
|
||||
(t (destructuring-bind (var &rest container-exprs) (first clauses)
|
||||
(cond
|
||||
((and var (symbolp var))
|
||||
`(funcall (monadic-map ,monad-instance (lambda (,var) ,expr))
|
||||
,(first container-exprs)))
|
||||
((and (consp var) (every #'symbolp var))
|
||||
`(multiple-value-call (monadic-map ,monad-instance
|
||||
(lambda (,@var) ,expr))
|
||||
,@container-exprs))
|
||||
(t (error "COMPREHEND: bad variable specification: ~s" vars))))))))
|
||||
|
||||
(defmacro define-monad (class-name
|
||||
&key comprehension
|
||||
(monad-param (gensym "MONAD-"))
|
||||
bases slots initargs
|
||||
((:map ((map-param)
|
||||
&body map-body)))
|
||||
((:join ((join-param
|
||||
&optional
|
||||
(j-rest-kw '&rest)
|
||||
(j-rest (gensym "JOIN-REST-")))
|
||||
&body join-body)))
|
||||
((:unit ((unit-param
|
||||
&optional
|
||||
(u-rest-kw '&rest)
|
||||
(u-rest (gensym "UNIT-REST-")))
|
||||
&body unit-body))))
|
||||
`(progn
|
||||
(defclass ,class-name ,bases ,slots)
|
||||
(defmethod monadic-instance ((monad (eql ',class-name)))
|
||||
(load-time-value (make-instance ',class-name ,@initargs)))
|
||||
(defmethod monadic-map ((,monad-param ,class-name) ,map-param)
|
||||
(declare (ignorable ,monad-param))
|
||||
,@map-body)
|
||||
(defmethod monadic-join ((,monad-param ,class-name)
|
||||
,join-param &rest ,j-rest)
|
||||
(declare (ignorable ,monad-param ,j-rest))
|
||||
,@join-body)
|
||||
(defmethod monadic-unit ((,monad-param ,class-name)
|
||||
,unit-param &rest ,u-rest)
|
||||
(declare (ignorable ,monad-param ,u-rest))
|
||||
,@unit-body)
|
||||
,@(if comprehension
|
||||
`((defmacro ,comprehension (expr &rest clauses)
|
||||
`(comprehend (monadic-instance ',',class-name)
|
||||
,expr ,@clauses))))))
|
||||
|
||||
(defmethod monadic-map ((monad symbol) function)
|
||||
(monadic-map (monadic-instance monad) function))
|
||||
|
||||
(defmethod monadic-join ((monad symbol) container-of-containers &rest rest)
|
||||
(apply #'monadic-join (monadic-instance monad) container-of-containers rest))
|
||||
|
||||
(defmethod monadic-unit ((monad symbol) element &rest rest)
|
||||
(apply #'monadic-unit (monadic-instance monad) element rest))
|
||||
|
||||
(define-monad list-monad
|
||||
:comprehension list-comp
|
||||
:map ((function) (lambda (container) (mapcar function container)))
|
||||
:join ((list-of-lists) (reduce #'append list-of-lists))
|
||||
:unit ((element) (list element)))
|
||||
|
||||
(define-monad identity-monad
|
||||
:comprehension identity-comp
|
||||
:map ((f) f)
|
||||
:join ((x &rest rest) (apply #'values x rest))
|
||||
:unit ((x &rest rest) (apply #'values x rest)))
|
||||
|
||||
(define-monad state-xform-monad
|
||||
:comprehension state-xform-comp
|
||||
:map ((f)
|
||||
(lambda (xformer)
|
||||
(lambda (s)
|
||||
(identity-comp (values (funcall f x) new-state)
|
||||
((x new-state) (funcall xformer s))))))
|
||||
:join ((nested-xformer)
|
||||
(lambda (s)
|
||||
(identity-comp (values x new-state)
|
||||
((embedded-xformer intermediate-state)
|
||||
(funcall nested-xformer s))
|
||||
((x new-state)
|
||||
(funcall embedded-xformer intermediate-state)))))
|
||||
:unit ((x) (lambda (s) (values x s))))
|
||||
27
Task/Metaprogramming/TXR/metaprogramming.txr
Normal file
27
Task/Metaprogramming/TXR/metaprogramming.txr
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
@(do
|
||||
(defmacro while ((condition : result) . body)
|
||||
(let ((cblk (gensym "cnt-blk-"))
|
||||
(bblk (gensym "brk-blk-")))
|
||||
^(macrolet ((break (value) ^(return-from ,',bblk ,value)))
|
||||
(symacrolet ((break (return-from ,bblk))
|
||||
(continue (return-from ,cblk)))
|
||||
(block ,bblk
|
||||
(for () (,condition ,result) ()
|
||||
(block ,cblk ,*body)))))))
|
||||
|
||||
(let ((i 0))
|
||||
(while ((< i 100))
|
||||
(if (< (inc i) 20)
|
||||
continue)
|
||||
(if (> i 30)
|
||||
break)
|
||||
(prinl i)))
|
||||
|
||||
(prinl
|
||||
(sys:expand
|
||||
'(while ((< i 100))
|
||||
(if (< (inc i) 20)
|
||||
continue)
|
||||
(if (> i 30)
|
||||
break)
|
||||
(prinl i)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue