Skip to content

Instantly share code, notes, and snippets.

@chiku-samugari
Created August 28, 2013 08:15
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save chiku-samugari/6363435 to your computer and use it in GitHub Desktop.
Save chiku-samugari/6363435 to your computer and use it in GitHub Desktop.
Live coding session at Lisp Meet Up #8 Devide the resulst of ``ls -l'' command into 2 sets by modulo 2 of the 2nd column (hard link count field) and sum up the 5th field (byte size field) of each set. Following code is available only for SBCL because PAPPLY macro depends on SB-C package.
(defparameter *sample*
(butlast (cdr (maplist (lambda (lst)
(when (cadr lst)
(subseq (str<-textfile "sample")
(1+ (car lst))
(cadr lst))))
(cons -1 (position-list #\Newline (str<-textfile "sample")))))))
(ql:quickload :split-sequence)
(let (even-set odd-set)
(dolist (line *sample*)
(let ((aline (remove "" (split-sequence:split-sequence #\Space line) :test #'equal)))
(cond ((evenp (parse-integer (second aline)))
(push (fifth aline) even-set))
((oddp (parse-integer (second aline)))
(push (fifth aline) odd-set))
(t 'YOU-ARE-STUPID!))))
(list (reduce (papply (+ _ (parse-integer _)))
(cdr even-set)
:initial-value (parse-integer (car even-set)))
(reduce (papply (+ _ (parse-integer _)))
(cdr odd-set)
:initial-value (parse-integer (car odd-set)))))
total 400
drwxr-xr-x 11 chiku staff 374 8 12 13:19 GLES20
drwxr-xr-x 3 chiku staff 102 7 14 18:12 Haskell
drwxr-xr-x 12 chiku staff 408 7 14 18:22 L5
drwxr-xr-x 30 chiku staff 1020 7 14 18:19 OCaml
drwxr-xr-x 3 chiku staff 102 8 16 05:12 R
drwxr-xr-x 6 chiku staff 204 7 14 18:24 androidccl
drwxr-xr-x 3 chiku staff 102 7 14 18:12 clojure
drwxr-xr-x 6 chiku staff 204 7 14 18:17 completion-driver
drwxr-xr-x 12 chiku staff 408 7 14 18:17 gwt-bvh
drwxr-xr-x 3 chiku staff 102 7 14 18:12 html
drwxr-xr-x 3 chiku staff 102 7 14 18:12 javascript
drwxr-xr-x 43 chiku staff 1462 8 26 20:28 lisp
drwxr-xr-x 4 chiku staff 136 7 14 18:17 p-parser
drwxr-xr-x 3 chiku staff 102 7 14 18:12 perl
drwxr-xr-x 8 chiku staff 272 7 14 18:16 postscript
drwxr-xr-x 20 chiku staff 680 7 14 18:15 practicals-1.0.3
-rw-r--r-- 1 chiku staff 204800 12 18 2012 practicals-1.0.3.tar.gz
drwxr-xr-x 17 chiku staff 578 7 14 18:29 rlwrap-filters
drwxr-xr-x 5 chiku staff 170 8 26 20:28 scheme
drwxr-xr-x 9 chiku staff 306 7 14 18:19 screen
drwxr-xr-x 4 chiku staff 136 7 14 18:13 sh
drwxr-xr-x 6 chiku staff 204 7 15 00:04 sqlite3
drwxr-xr-x 3 chiku staff 102 8 16 10:22 vimscript
(defun concat-str (&rest strs)
(apply #'concatenate (cons 'string strs)))
(defun str<-textfile (filename &optional (omit-pred #'null))
" The parameter ``omit-pred'' is used as a predicator for line-wise
checking of taking that line or not."
(with-open-file (in filename :direction :input)
(when in
(do ((line (read-line in nil nil) (read-line in nil nil))
(str ""))
((null line) str)
(unless (funcall omit-pred line)
(setf str (concat-str str line (string #\newline))))))))
(defun position-list (item seq &key (key #'identity) (test #'eql))
(labels ((rec (s acc)
(let ((pos (position item s :key key :test test)))
(if pos
(rec (subseq s (1+ pos)) (cons (1+ pos) acc))
(nreverse (maplist #'(lambda (x) (reduce #'+ x)) acc))))))
(rest (rec seq (list -1)))))
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun maptree (func tree &key (pred #'atom))
(if (funcall pred tree) (funcall func tree)
(mapcar #'(lambda (x) (maptree func x :pred pred)) tree))))
(defmacro with-tree-leaves (tree test-form result-form)
`(maptree (lambda (leaf) (if ,test-form ,result-form leaf)) ,tree))
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym)))
,@body))
(defun last1 (lst) (car (last lst)))
(defmacro dequeue! (lst)
(with-gensyms (alt-lst)
`(let ((,alt-lst ,lst))
(prog1 (last1 ,alt-lst)
(setf ,alt-lst (butlast ,alt-lst))
(setf ,lst ,alt-lst)))))
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun count-underscore (tree)
(let ((c 0))
(with-tree-leaves tree (eq leaf '_) (incf c))
c)))
(defmacro papply-listup-format (fn &rest applying-args &environment env)
(let* ((gensym-lst)
(body (with-tree-leaves applying-args
(eq leaf '_)
(car (push (gensym "PARG") gensym-lst)))))
(with-gensyms (not-applied-args)
`(lambda (,@(mapcan (lambda (x)
(loop repeat (count-underscore x)
collect (dequeue! gensym-lst)))
applying-args)
&rest ,not-applied-args)
(apply
,(if (symbolp fn)
(if (member fn (sb-c::lexenv-vars env) :key #'car :test #'eq)
fn `#',fn)
fn)
,@body ,not-applied-args)))))
(defmacro papply-form-format ((op &rest applying-args))
`(papply-listup-format ,op ,@applying-args))
(defmacro papply (&rest op-and-args)
" papply (op &rest applying-args) => function ;{{{
papply op &rest applying-args => function
op : a symbol or function object.
applying-args : objects.
function : a function object.
This macro basically generates a function object by applying the first
m argument of ``op'' to ``applying-args.'' m is the number of elemetns
in ``applying-args'' except the symbol ``_''.
Special symbol ``_'' works as the place holder for not-yet-applied
arguments. The nth ``_'' is replaced by the nth argument of the result
function object. The order is from left to right. In other terminology,
depth-first-order.
Symbols are valid to be specified to ``op.'' If a symbol is given
for ``op'', then normaly it is treated as a symbol of a function.
But if the symbol is a variable which is lexically bound, then it is
treated as a variable. If you want to pass the function which is
indicated by that symbol in such a case, use function object instaed
of symbol (just put #' in front of the symbol).
This macro accepts 2 different format. One is called ``form format''
because it seems like one form:
(papply (cons (+ 1 _)))
The another format is called ``listup format'' because it list up
the function and its argument one by one:
(papply #'cons (+ 1 _))
Both of them accepts some more variations. As described above, ``op''
can be a symbol that denotes a (globally defined) function or a symbol
that is used as a lexical variable and bound to a function object.
Thus, all follwing format is the same thing.
(papply (cons (+ 1 _)))
(papply (#'cons (+ 1 _)))
(let ((- #'cons))
(papply (- (+ 1 _))))
(papply #'cons (+ 1 _))
(papply cons (+ 1 _))
(let ((- #'cons))
(papply - (+ 1 _)))
;}}}"
(cond ((or (atom (car op-and-args)) (eq (caar op-and-args) 'function))
`(papply-listup-format ,(car op-and-args) ,@(cdr op-and-args)))
(t `(papply-form-format ,@op-and-args))))
@chiku-samugari
Copy link
Author

That's it! I've never noticed that parameter.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment