Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 146 lines (117 sloc) 4.389 kb
d356d1b2 »
2011-01-15 Lots of new documentation.
1 (require 'codewalking-utils)
2 (require 'utils)
7a1b824e »
2011-03-01 Added lambda*, defun-recur, parse-lambda-list
3 (require 'cl)
d356d1b2 »
2011-01-15 Lots of new documentation.
4
5 (defmacro defcompose (name &rest fs)
9dabfe0f »
2011-02-02 microstack first
6 "Defun a new function NAME as a composition of other functions FS. If (car FS) is a string, use this as the doc string."
d356d1b2 »
2011-01-15 Lots of new documentation.
7 (let ((args (gensym (format "%s-args" name))))
9dabfe0f »
2011-02-02 microstack first
8 (if (stringp (car fs))
9 `(defun ,name (&rest ,args) ,(car fs)
10 (apply (comp ,@(cdr fs)) ,args))
11 `(defun ,name (&rest ,args)
12 (apply (comp ,@fs) ,args)))))
13
7a1b824e »
2011-03-01 Added lambda*, defun-recur, parse-lambda-list
14 (defun /|-argpred (x)
15 (and (symbolp x)
16 (let* ((strv (format "%s" x))
17 (first-char (substring strv 0 1))
18 (rest-chars (substring strv 1 (length strv)))
19 (rest-count (string-to-number rest-chars)))
20 (and (string= "%" first-char)
21 (> rest-count 0)))))
22
23 (defun arg-num (arg)
24 (let* ((strv (format "%s" arg))
25 (first-char (substring strv 0 1))
26 (rest-chars (substring strv 1 (length strv)))
27 (rest-count (string-to-number rest-chars)))
28 rest-count))
29
30 (defun arg< (arg1 arg2)
31 (< (arg-num arg1) (arg-num arg2)))
32
33 (defmacro* /| (&body body)
34 (let* ((expanded (macroexpand-all `(progn ,@body)))
35 (usage-info (collect-usage-info expanded))
36 (args (filter #'/|-argpred (get-unbound-symbols-list usage-info)))
37 (args (functional-sort args #'arg<)))
38 `(function (lambda ,args ,expanded))))
9dabfe0f »
2011-02-02 microstack first
39
40 (defmacro defcurrly-doc (newname doc f &rest args)
41 "Define a function by left-most partial application with doc string."
9b284ac5 »
2010-10-10 Monadic parser update, bug fixes.
42 (let ((narglist (gensym (format "%s-arglist" newname))))
43 `(defun ,newname (&rest ,narglist)
9dabfe0f »
2011-02-02 microstack first
44 ,doc
45 (apply ,f ,@args ,narglist))))
9b284ac5 »
2010-10-10 Monadic parser update, bug fixes.
46
9dabfe0f »
2011-02-02 microstack first
47 (defmacro defcurryl-no-doc (newname f &rest args)
48 "Define a function by left-most partial application without doc string."
9b284ac5 »
2010-10-10 Monadic parser update, bug fixes.
49 (let ((narglist (gensym (format "%s-arglist" newname))))
50 `(defun ,newname (&rest ,narglist)
9dabfe0f »
2011-02-02 microstack first
51 (apply ,f ,@args ,narglist))))
52
53 (defmacro defcurryl (newname &rest args)
54 "Define a function with left-most partial application on another function."
302bcdaa »
2011-02-13 Multimethods library, bros
55 `(defcurryl-no-doc ,newname ,@args))
56 ;; (if (stringp (car args))
57 ;; `(defcurryl-doc ,newname ,(car args) ,@(cdr args))
58 ;; `(defcurryl-no-doc ,newname ,@args)))
9dabfe0f »
2011-02-02 microstack first
59
302bcdaa »
2011-02-13 Multimethods library, bros
60 (defmacro defcurryr (newname oldname &rest args)
61 (let ((narglist (gensym (format "%s-arglist" newname))))
62 `(defun ,newname (&rest ,narglist)
63 (apply ,oldname (append ,narglist (list ,@args))))))
9dabfe0f »
2011-02-02 microstack first
64
302bcdaa »
2011-02-13 Multimethods library, bros
65 (defmacro clambdal (oldf &rest args)
66 (let ((narglist (gensym "clambdal-arglist-")))
67 `(lambda (&rest ,narglist)
68 (apply ,oldf ,@args ,narglist))))
9dabfe0f »
2011-02-02 microstack first
69
302bcdaa »
2011-02-13 Multimethods library, bros
70 (defmacro cl (&rest stuff)
71 `(clambdal ,@stuff))
9dabfe0f »
2011-02-02 microstack first
72
73
302bcdaa »
2011-02-13 Multimethods library, bros
74 (defmacro clambdar (oldf &rest args)
75 (let ((narglist (gensym "clambdal-arglist-")))
76 `(lambda (&rest ,narglist)
77 (apply ,oldf (append ,narglist (list ,@args))))))
9dabfe0f »
2011-02-02 microstack first
78
302bcdaa »
2011-02-13 Multimethods library, bros
79 (defmacro cr (&rest stuff)
80 `(clambdar ,@stuff))
9dabfe0f »
2011-02-02 microstack first
81
7a1b824e »
2011-03-01 Added lambda*, defun-recur, parse-lambda-list
82 (defun par (f &rest partially-applied-args)
83 (lexical-let ((f f)
84 (partially-applied-args partially-applied-args))
85 (lambda (&rest unapplied)
86 (apply f (append unapplied partially-applied-args)))))
87
88 (defun pal (f &rest partially-applied-args)
89 (lexical-let ((f f)
90 (partially-applied-args partially-applied-args))
91 (lambda (&rest unapplied)
92 (apply f (append partially-applied-args unapplied)))))
9dabfe0f »
2011-02-02 microstack first
93
302bcdaa »
2011-02-13 Multimethods library, bros
94 (defmacro defdecorated (newname oldname transformer)
95 (let ((args (gensym (format "%s-decorated-args" newname))))
96 `(defun ,newname (&rest ,args)
97 (apply ,oldname
98 (funcall ,transformer ,args)))))
9dabfe0f »
2011-02-02 microstack first
99
100 (defmacro lambdecorate (oldf transformer)
101 (let ((args (gensym (format "decorated-args"))))
102 `(lambda (&rest ,args)
103 (apply #',oldf
104 (funcall #',transformer ,args)))))
105
106 (lex-defun f-and-2 (f1 f2)
107 (lambda (&rest args)
108 (and (apply f1 args)
109 (apply f2 args))))
110
111 (lex-defun f-and (&rest fs)
112 (reduce #'f-and-2 fs))
113
114 (lex-defun f-or-2 (f1 f2)
115 (lambda (&rest args)
116 (or (apply f1 args)
117 (apply f2 args))))
118
119 (lex-defun f-or (&rest fs)
120 (reduce #'f-or-2 fs))
121
122 (lex-defun f-not (f)
123 (lambda (&rest args)
124 (not (apply f args))))
125
126 (lex-defun f-mapcar (f)
127 (lambda (&rest args)
128 (apply #'mapcar (cons f args))))
129
b85fabef »
2011-03-16 made monad-parse independent of defn
130 (lex-defun decorate-all (f dec)
131 (lambda (&rest args)
132 (apply f (mapcar dec args))))
133
5a0b47c7 »
2011-04-09 monad tutorial, fixed curry word.
134 (lex-defun decorate-n (f index trans)
135 (lambda (&rest args)
136 (let* ((el (elt args index))
137 (new (funcall trans el)))
138 (setf (elt args index) new)
139 (apply f args))))
140
141 (lex-defun f-comb-with (f-comb f1 f2)
142 (lambda (&rest args)
143 (funcall f-comb (apply f1 args) (apply f2 args))))
144
d356d1b2 »
2011-01-15 Lots of new documentation.
145
9b284ac5 »
2010-10-10 Monadic parser update, bug fixes.
146 (provide 'functional)
Something went wrong with that request. Please try again.