git.fiddlerwoaroof.com
Browse code

adding stuff

fiddlerwoaroof authored on 16/09/2017 19:54:07
Showing 22 changed files
.gitignore
History View file @ 1a481a6
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+.[#]*
2 
+[#]*
3 
+gen-patmatch.fasl
4 
+timer.fasl
5 
+*.fasl
anonymous-generic-functions.lisp
History View file @ 1a481a6
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,69 @@
1 
+(defpackage :anonymous-generic-function
2 
+  (:use :cl :alexandria)
3 
+  (:export :lambda-generic))
4 
+(in-package :anonymous-generic-function)
5 
+
6 
+(defmacro defun-ct (name (&rest args) &body body)
7 
+  `(eval-when (:load-toplevel :compile-toplevel :execute)
8 
+     (defun ,name ,args
9 
+       ,@body)))
10 
+
11 
+(defun-ct make-anonymous-generic-function (lambda-list methods)
12 
+  (declare (optimize (debug 3)))
13 
+  (let* ((gf (make-instance 'standard-generic-function
14 
+                            :lambda-list lambda-list))
15 
+         (mc (closer-mop:generic-function-method-class gf)))
16 
+    (prog1 gf
17 
+      (loop for (specializers qualifiers body) in methods
18 
+         for (method-lambda initargs) = (multiple-value-list (closer-mop:make-method-lambda gf (closer-mop:class-prototype mc)
19 
+                                                                                            `(lambda ,lambda-list
20 
+                                                                                               ,@body)
21 
+                                                                                            nil))
22 
+         do
23 
+           (add-method gf
24 
+                       (apply #'make-instance mc
25 
+                              :function (compile nil method-lambda)
26 
+                              :specializers specializers
27 
+                              :qualifiers qualifiers
28 
+                              :lambda-list lambda-list
29 
+                              initargs))))))
30 
+
31 
+(defun-ct take-until (pred list)
32 
+  (loop for (item . rest) on list
33 
+     until (funcall pred item)
34 
+     collect item into items
35 
+     finally
36 
+       (return (values items
37 
+                       (cons item rest)))))
38 
+
39 
+(defun-ct get-specializers (specialized-lambda-list)
40 
+  (flet ((get-specializer (specializer)
41 
+           (etypecase specializer
42 
+             (symbol (find-class specializer))
43 
+             (cons (ecase (car specializer)
44 
+                     ('eql (closer-mop:intern-eql-specializer (cdr specializer))))))))
45 
+    (mapcar (lambda (specialized-arg)
46 
+              (if (listp specialized-arg)
47 
+                  (get-specializer (cadr specialized-arg))
48 
+                  (find-class t)))
49 
+            specialized-lambda-list)))
50 
+
51 
+(defun-ct get-methods (method-definition-list)
52 
+  (loop for (keyword . rest) in method-definition-list
53 
+     unless (eq keyword :method) do
54 
+       (error "method definitions must begin with the :METHOD keyword")
55 
+     collect
56 
+       (multiple-value-bind (qualifiers rest) (take-until #'listp rest)
57 
+         (list (get-specializers (car rest))
58 
+               qualifiers
59 
+               (cdr rest)))))
60 
+
61 
+(defmacro lambda-generic ((&rest lambda-list) &body methods)
62 
+  (let ((methods (get-methods methods)))
63 
+    `(make-anonymous-generic-function ',lambda-list ',methods)))
64 
+
65 
+#+null
66 
+(lambda-generic (a b)
67 
+  (:method ((a integer) (b integer)) (+ a b))
68 
+  (:method (a b) 2)
69 
+  (:method :after (a b) (format t "~&~d ~d~%" a b)))
block-to-sexp.lisp
History View file @ 1a481a6
0 70 
new file mode 100644
... ... 
@@ -0,0 +1,82 @@
1 
+(defpackage :block-to-sexp
2 
+  (:use :cl))
3 
+(in-package :block-to-sexp)
4 
+
5 
+(defun read-block (stream)
6 
+  (when (char= (read-char stream) #\{)
7 
+    (loop
8 
+       with block = (make-string-output-stream)
9 
+       with count = 0
10 
+       for char = (read-char stream)
11 
+       until (and (char= char #\}) (= count 0))
12 
+       when (char= char #\{) do (incf count)
13 
+       when (char= char #\}) do (decf count)
14 
+       do (write-char char block)
15 
+       finally
16 
+	 (return (get-output-stream-string block)))))
17 
+
18 
+(defun read-to-block (stream)
19 
+  (with-output-to-string (s)
20 
+    (loop
21 
+       until (char= #\{ (peek-char nil stream))
22 
+       do (write-char (read-char stream) s))))
23 
+
24 
+(defun partition (char string &key from-end)
25 
+  (let ((pos (position char string :from-end from-end)))
26 
+    (if pos
27 
+	(list (subseq string 0 pos)
28 
+	      (subseq string (1+ pos)))
29 
+	(list nil
30 
+	      string))))
31 
+
32 
+(defun parse-rule (block)
33 
+  (mapcar #'serapeum:tokens
34 
+	  (serapeum:split-sequence #\;
35 
+				   (serapeum:collapse-whitespace block)
36 
+				   :remove-empty-subseqs t)))
37 
+
38 
+(defun read-section (stream)
39 
+  (cons (serapeum:collapse-whitespace (read-to-block stream))
40 
+	(parse-rule (read-block stream))))
41 
+
42 
+(defun parse-file (stream)
43 
+  (loop with result = (list)
44 
+     with done = nil
45 
+     until done
46 
+     do
47 
+       (handler-case (push (read-section stream)
48 
+			   result)
49 
+	 (end-of-file (c) c (setf done t)))
50 
+     finally
51 
+       (return (nreverse result))))
52 
+
53 
+(defun collapse-rule (rule)
54 
+  (let ((selector (car rule)))
55 
+    (mapcan (serapeum:op (mapcar (lambda (x) (list x _))
56 
+				 selector))
57 
+	    (cdr rule))))
58 
+
59 
+(defun reconstitute (rules)
60 
+  (loop for (selector (property value)) in rules
61 
+       collect (format nil "~a { ~a: ~a; }" selector property value)))
62 
+
63 
+(defun normalize-file (stream)
64 
+  (fw.lu:let-each (:be *)
65 
+    (parse-file stream)
66 
+    (mapcan #'collapse-rule *)
67 
+    (stable-sort * #'string< :key #'caadr)
68 
+    (reconstitute *)
69 
+    (serapeum:string-join * #\newline)))
70 
+
71 
+(defun test-read-block ()
72 
+  (let ((strings (list "asdf cda qwer dsfa"
73 
+		       (format nil "asdf fdsaf ~% asdf qwerqw~%")
74 
+		       (format nil "{asdf fdsaf ~% asdf qwerqw~%}")
75 
+		       (format nil "asdf fdsaf {~% asdf qwerqw~%}"))))
76 
+    (loop
77 
+       for string in strings
78 
+       for n from 1
79 
+       do
80 
+	 (with-input-from-string (s (format nil "{~a}" string))
81 
+	   (format t "~&Test ~d: ~:[fail~;pass~]~%" n
82 
+		   (string= string (read-block s)))))))
clim-test.lisp
History View file @ 1a481a6
0 83 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+(
2 
+ ,q (use :cl)
3 
+    fwoar.-clisp  0,qdefpackage :clim-test-app
4 
+    (:use :clim :cli-userfwoar)).
5 
+
6 
+
7 
+
8 
+*package*
9 
+,q (cl:use-package :clim-lisp)
10 
+0
11 
+*pack
12 
+,q (import cl:*package*)
13 
+0,'
14 
+0panes
15 
+(text (make-pane 'text-fi )) j$hs test-app ()
16 
+edi
17 
+(ql:quickload :cl
18 
+	      ,q (delete-package :clim-test-app)
19 
+
20 
+	      ,q
21 
+	      (clim-demo:demodemo)) q
css-norm.lisp
History View file @ 1a481a6
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,91 @@
1 
+(defpackage :css-norm
2 
+  (:use :cl))
3 
+(in-package :css-norm)
4 
+
5 
+(defun read-block (stream)
6 
+  (when (char= (read-char stream) #\{)
7 
+    (loop
8 
+       with block = (make-string-output-stream)
9 
+       with count = 0
10 
+       for char = (read-char stream)
11 
+       until (and (char= char #\}) (= count 0))
12 
+       when (char= char #\{) do (incf count)
13 
+       when (char= char #\}) do (decf count)
14 
+       do (write-char char block)
15 
+       finally
16 
+	 (return (get-output-stream-string block)))))
17 
+
18 
+(defun read-to-block (stream)
19 
+  (with-output-to-string (s)
20 
+    (loop
21 
+       until (char= #\{ (peek-char nil stream))
22 
+       do (write-char (read-char stream) s))))
23 
+
24 
+(defun partition (char string &key from-end)
25 
+  (let ((pos (position char string :from-end from-end)))
26 
+    (if pos
27 
+	(list (subseq string 0 pos)
28 
+	      (subseq string (1+ pos)))
29 
+	(list nil
30 
+	      string))))
31 
+
32 
+(defun parse-rule (block)
33 
+  (remove-if-not #'car
34 
+		 (mapcar (serapeum:op
35 
+			   (mapcar (serapeum:op
36 
+				     (and _1 (serapeum:trim-whitespace _1)))
37 
+				   (partition #\: _)))
38 
+			 (serapeum:split-sequence #\;
39 
+						  (serapeum:collapse-whitespace block)))))
40 
+
41 
+(defun parse-selector (selector)
42 
+  (mapcar #'serapeum:trim-whitespace
43 
+	  (split-sequence:split-sequence #\, selector)))
44 
+
45 
+(defun read-rule (stream)
46 
+  (cons (funcall (alexandria:compose #'parse-selector
47 
+				     #'serapeum:collapse-whitespace)
48 
+		 (read-to-block stream))
49 
+	(parse-rule (read-block stream))))
50 
+
51 
+(defun parse-file (stream)
52 
+  (loop with result = (list)
53 
+     with done = nil
54 
+     until done
55 
+     do
56 
+       (handler-case (push (read-rule stream)
57 
+			   result)
58 
+	 (end-of-file (c) c (setf done t)))
59 
+     finally
60 
+       (return (nreverse result))))
61 
+
62 
+(defun collapse-rule (rule)
63 
+  (let ((selector (car rule)))
64 
+    (mapcan (serapeum:op (mapcar (lambda (x) (list x _))
65 
+				 selector))
66 
+	    (cdr rule))))
67 
+
68 
+(defun reconstitute (rules)
69 
+  (loop for (selector (property value)) in rules
70 
+       collect (format nil "~a { ~a: ~a; }" selector property value)))
71 
+
72 
+(defun normalize-file (stream)
73 
+  (fw.lu:let-each (:be *)
74 
+    (parse-file stream)
75 
+    (mapcan #'collapse-rule *)
76 
+    (stable-sort * #'string< :key #'caadr)
77 
+    (reconstitute *)
78 
+    (serapeum:string-join * #\newline)))
79 
+
80 
+(defun test-read-block ()
81 
+  (let ((strings (list "asdf cda qwer dsfa"
82 
+		       (format nil "asdf fdsaf ~% asdf qwerqw~%")
83 
+		       (format nil "{asdf fdsaf ~% asdf qwerqw~%}")
84 
+		       (format nil "asdf fdsaf {~% asdf qwerqw~%}"))))
85 
+    (loop
86 
+       for string in strings
87 
+       for n from 1
88 
+       do
89 
+	 (with-input-from-string (s (format nil "{~a}" string))
90 
+	   (format t "~&Test ~d: ~:[fail~;pass~]~%" n
91 
+		   (string= string (read-block s)))))))
curly-braces.lisp
History View file @ 1a481a6
0 92 
new file mode 100644
... ... 
@@ -0,0 +1,30 @@
1 
+(defpackage :curly-bracens
2 
+  (:use :cl :named-readtables))
3 
+(in-package :curly-bracens)
4 
+(shadow 'if)
5 
+
6 
+(defmacro if (condition then &optional (else-sym nil e-s-p) (else nil e-p))
7 
+  (assert (and e-s-p e-p (eq else-sym 'else)))
8 
+  `(cl:if ,condition
9 
+          ,then
10 
+          ,else))
11 
+
12 
+(defun read-progn (stream char)
13 
+  (declare (ignore char))
14 
+  (cons 'progn
15 
+        (read-delimited-list #\} stream t)))
16 
+
17 
+(defreadtable :curly-bracens
18 
+  (:merge :standard)
19 
+  (:macro-char #\} (lambda (&rest r) (declare (ignore r))) nil)
20 
+  (:macro-char #\{ 'read-progn nil))
21 
+
22 
+(if (> 3 1) {
23 
+  (princ :hi)
24 
+  (terpri)
25 
+  (+ 2 3)
26 
+} else {
27 
+  (princ :bye)
28 
+  (terpri)
29 
+  (+ 4 5)
30 
+})
ddns_updater.lisp
History View file @ 1a481a6
0 31 
new file mode 100644
... ... 
@@ -0,0 +1,59 @@
1 
+(eval-when (:load-toplevel :execute)
2 
+  (format t "~&Loading dependencies...")
3 
+  (ql:quickload '(:alexandria :serapeum :fwoar.lisputils :drakma :flexi-streams :osicat :yason)))
4 
+
5 
+(eval-when (:load-toplevel :execute)
6 
+  (format t "~&Loading dependencies...")
7 
+  (osicat-posix:setenv "CC" "/usr/bin/gcc")
8 
+  (ql:quickload :net.didierverna.clon))
9 
+
10 
+(defpackage :ddclient-updater
11 
+  (:use :cl :alexandria :serapeum :fw.lu)
12 
+  (:export :update-domains))
13 
+(in-package :ddclient-updater)
14 
+
15 
+(defparameter *update-url* "https://api.1984.is/1.0/freedns/?apikey=~a&domain=~a&ip=")
16 
+
17 
+(defvar *http-stream* nil)
18 
+
19 
+(defun update-domain (domain api-key)
20 
+  (let* ((url (format nil *update-url* api-key domain))
21 
+	 (drakma:*text-content-types* (acons "application" "json" drakma:*text-content-types*)))
22 
+    ;; todo: we probably want to read the stream in, because yason isn't completely robust against early termination
23 
+    (multiple-value-bind (data _ __ ___ ____ stream) (drakma:http-request url :close nil :stream *http-stream*)
24 
+      (declare (ignore _ __ ___ ____))
25 
+      (unless *http-stream*
26 
+	(setf *http-stream* stream))
27 
+      (with (result (yason:parse data))
28 
+	(values result
29 
+		(gethash "ok" result)
30 
+		(gethash "msg" result))))))
31 
+
32 
+(defun update-domains (domains api-key)
33 
+  (mapcar (op (with-simple-restart (continue "Skip ~a" _1)
34 
+		(format t "~&Updating ~a...~%" _1)
35 
+		(prog1 (multiple-value-list (update-domain _1 api-key))
36 
+		  (sleep 1))))
37 
+	  domains))
38 
+
39 
+(defpackage :ddclient-updater.main
40 
+  (:use :cl :alexandria :serapeum :fw.lu :net.didierverna.clon :ddclient-updater))
41 
+(in-package :ddclient-updater.main)
42 
+(import 'ddclient-updater::*http-stream*)
43 
+
44 
+(defparameter *api-key* "rKOB3TrfjWfsUl6NpvN6A3vYTaQfdXgYTShDAFWI5rwHJKwFb0EyBT7Mt11YWrjV")
45 
+(defparameter *domains* '("srv2.elangley.org" "vpn.elangley.org" "files.elangley.org" "home.elangley.org"
46 
+			  "mycloud.elangley.org" "pbj.elangley.org" "readme.elangley.org"
47 
+			  "wiki.elangley.org"))
48 
+
49 
+(defsynopsis ()
50 
+  )
51 
+(defun main ()
52 
+  (make-context)
53 
+  (unwind-protect (update-domains *domains* *api-key*)
54 
+    (when *http-stream*
55 
+      (finish-output *http-stream*)
56 
+      (close *http-stream*))))
57 
+
58 
+(defun dump-image ()
59 
+  (dump "ddns-updater" main))
extract-dates.lisp
History View file @ 1a481a6
0 60 
new file mode 100644
... ... 
@@ -0,0 +1,148 @@
1 
+(defpackage :zfs-cleaner.utils
2 
+  (:use :cl)
3 
+  (:export #:regex-match #:include #:exclude #:pick
4 
+           #:snapshot-to-vector #:vector-to-lt #:key-transform
5 
+           #:combine #:derive #:cumsum #:over #:on #:shortcut
6 
+           #:defun-ct))
7 
+(in-package :zfs-cleaner.utils)
8 
+
9 
+(defmacro shortcut (name function &body bound-args)
10 
+  `(eval-when (:load-toplevel :compile-toplevel :execute)
11 
+     (setf (fdefinition ',name)
12 
+           (,function ,@bound-args))))
13 
+
14 
+(defmacro defun-ct (name (&rest args) &body body)
15 
+  `(eval-when (:load-toplevel :compile-toplevel :execute)
16 
+     (defun ,name ,args
17 
+       ,@body)))
18 
+
19 
+(defun-ct regex-match (regex)
20 
+  (lambda (data)
21 
+    (cl-ppcre:scan-to-strings regex data)))
22 
+
23 
+(defun-ct include (pred)
24 
+  (lambda (seq)
25 
+    (remove-if-not pred seq)))
26 
+
27 
+(defun-ct exclude (pred)
28 
+  (lambda (seq)
29 
+    (remove-if pred seq)))
30 
+
31 
+(defun-ct pick (selector)
32 
+  (lambda (seq)
33 
+    (map 'list selector seq)))
34 
+
35 
+(defun-ct key-transform (fun key-get key-set)
36 
+  (lambda (it)
37 
+    (let ((key-val (funcall key-get it)))
38 
+      (funcall key-set
39 
+               (funcall fun key-val)))))
40 
+
41 
+(defun-ct combine (fun1 fun2)
42 
+  (lambda (item)
43 
+    (list (funcall fun1 item)
44 
+          (funcall fun2 item))))
45 
+
46 
+(defun-ct derive (diff-fun &key (key #'identity))
47 
+  (lambda (list)
48 
+    (mapcar (lambda (next cur)
49 
+              (cons (funcall diff-fun (funcall key next) (funcall key  cur))
50 
+                    next))
51 
+            (cdr list)
52 
+            list)))
53 
+
54 
+(defun-ct cumsum (&key (add-fun #'+) (key #'identity) (combine (lambda (x y) y x)) (zero 0))
55 
+  (lambda (seq)
56 
+    (nreverse
57 
+     (reduce (lambda (accum next)
58 
+               (let ((key-val (funcall key next))
59 
+                     (old-val (if accum
60 
+                                  (funcall key (car accum))
61 
+                                  zero)))
62 
+                 (cons (funcall combine
63 
+                                (funcall add-fun old-val key-val)
64 
+                                next)
65 
+                       accum)))
66 
+             seq
67 
+             :initial-value ()))))
68 
+
69 
+(defun-ct over (fun &key (result-type 'list))
70 
+  (lambda (seq)
71 
+    (map result-type fun seq)))
72 
+
73 
+(defun-ct on (fun key)
74 
+  (lambda (it)
75 
+    (funcall fun (funcall key it))))
76 
+
77 
+(defpackage :zfs-cleaner
78 
+  (:use :cl :zfs-cleaner.utils))
79 
+(in-package :zfs-cleaner)
80 
+
81 
+(defgeneric %get-snapshots (env)
82 
+  (:method ((env (eql :dev)))
83 
+    (alexandria:read-file-into-string #p "/tmp/feeds"))
84 
+  (:method ((env (eql :prod)))
85 
+    (with-output-to-string (s)
86 
+      (uiop:run-program "zfs list -r -t snapshot -H -p tank/feed_archive/feeds"
87 
+                        :output s))))
88 
+
89 
+(defun get-snapshots (&optional (env :dev))
90 
+  (%get-snapshots env))
91 
+
92 
+(shortcut find-date regex-match
93 
+  '(:group
94 
+    (:named-register "year" (:greedy-repetition 4 4 :digit-class)) #\-
95 
+    (:named-register "month" (:greedy-repetition 2 2 :digit-class)) #\-
96 
+    (:named-register "day" (:greedy-repetition 2 2 :digit-class)) #\-
97 
+    (:named-register "hour" (:greedy-repetition 2 2 :digit-class)) #\-
98 
+    (:named-register "minute" (:greedy-repetition 2 2 :digit-class))))
99 
+
100 
+(defun-ct snapshot-to-vector (name)
101 
+  (map 'vector #'parse-integer
102 
+       (nth-value 1 (find-date name))))
103 
+
104 
+(defun-ct vector-to-lt (vec)
105 
+  (apply 'local-time:encode-timestamp
106 
+         0 0
107 
+         (coerce (reverse vec)
108 
+                 'list)))
109 
+
110 
+(defstruct (zfs-date (:type vector))
111 
+  year month day hour minute)
112 
+
113 
+(defparameter +date-format+
114 
+  '((:year 4) #\-
115 
+    (:month 2) #\-
116 
+    (:day 2) #\-
117 
+    (:hour 2) #\-
118 
+    (:min 2)))
119 
+
120 
+(defun get-snapshots-to-prune (snapshots)
121 
+  (labels ((first-column (it)
122 
+             (elt (fwoar.string-utils:split #\tab it)
123 
+                  0))
124 
+           (is-saved-snapshot (ts)
125 
+             (or (is-hourly-snapshot ts)
126 
+                 (not (is-stale ts))))
127 
+           (is-hourly-snapshot (it)
128 
+             (= (local-time:timestamp-minute it)
129 
+                0))
130 
+           (is-stale (item)
131 
+             (local-time:timestamp< item
132 
+                                    (local-time:timestamp- (local-time:now)
133 
+                                                           2 :day))))
134 
+    (funcall (alexandria:compose (pick #'second)
135 
+                                 (exclude (alexandria:compose (on #'is-saved-snapshot #'first)))
136 
+                                 (over (combine (alexandria:compose #'vector-to-lt
137 
+                                                                    #'snapshot-to-vector)
138 
+                                                #'first-column))
139 
+                                 (include 'find-date))
140 
+             (fwoar.string-utils:split #\newline snapshots))))
141 
+
142 
+(defun dev-main ()
143 
+  (let ((snapshots (get-snapshots :dev)))
144 
+    (format t "~&~{~a~%~}" (get-snapshots-to-prune snapshots))))
145 
+
146 
+(defun prod-main ()
147 
+  (let ((snapshots (get-snapshots :prod)))
148 
+    (format t "~&~{~a~%~}" (get-snapshots-to-prune snapshots))))
gen-patmatch.lisp
History View file @ 1a481a6
0 149 
new file mode 100644
... ... 
@@ -0,0 +1,44 @@
1 
+(defpackage :patmatch
2 
+  (:use :cl :alexandria :serapeum)
3 
+  (:export pat-match))
4 
+(in-package :patmatch)
5 
+
6 
+(eval-when (:compile-toplevel :load-toplevel :execute)
7 
+  (defgeneric handle-pattern (pattern form &rest args)
8 
+    (:method ((pattern cons) form &rest args)
9 
+      (let ((val-sym (gensym "VAL")))
10 
+        (destructuring-bind (car cdr) args
11 
+          `((,val-sym ,form)
12 
+            (,car (car ,val-sym))
13 
+            (,cdr (cdr ,val-sym))))))
14 
+
15 
+    (:method ((pattern vector) form &rest args)
16 
+      (let ((val-sym (gensym "VAL")))
17 
+        `((,val-sym ,form)
18 
+          ,@ (loop for arg in args
19 
+                for idx from 0
20 
+                collect `(,arg (aref ,val-sym ,idx))))))
21 
+
22 
+    (:method ((pattern hash-table) form &rest args)
23 
+      (let* ((val-sym (gensym "VAL"))
24 
+             (binding-forms (loop for (key sym) in args
25 
+                               append `((,sym (gethash ',key ,val-sym))))))
26 
+        `((,val-sym ,form)
27 
+          ,@binding-forms)))
28 
+
29 
+    (:method ((pattern symbol) form &rest args)
30 
+      (apply #'handle-pattern
31 
+             (closer-mop:class-prototype
32 
+              (find-class pattern))
33 
+             form
34 
+             args))))
35 
+
36 
+(defmacro pattern-match ((&rest clauses) &body body)
37 
+  `(let* (,@ (loop for ((discriminator . args) val-form) in clauses
38 
+                append (apply 'handle-pattern discriminator val-form args)))
39 
+     ,@body))
40 
+
41 
+
42 
+
43 
+(pattern-match (((hash-table (:a a) (:b b)) (plist-hash-table '(:a 1 :b 2))))
44 
+  (+ a b))
jsonarr-to-table.lisp
History View file @ 1a481a6
0 45 
new file mode 100644
... ... 
@@ -0,0 +1,43 @@
1 
+(eval-when (:compile-toplevel :load-toplevel :execute)
2 
+  (load "~/quicklisp/setup.lisp")
3 
+  (ql:quickload '(:yason :alexandria :serapeum :fwoar.lisputils :osicat))
4 
+  (osicat-posix:setenv "CC" "/usr/bin/gcc")
5 
+  (ql:quickload :net.didierverna.clon))
6 
+
7 
+(defpackage :json-to-table
8 
+  (:use :cl :alexandria :serapeum :fw.lu))
9 
+(in-package :json-to-table)
10 
+
11 
+(defun hash-table-alist-rec (h-t)
12 
+  (map-tree
13 
+   (op (typecase _1
14 
+	 (hash-table (hash-table-alist _1))
15 
+	 (t _1)))
16 
+   (hash-table-alist h-t)))
17 
+
18 
+(defun get-all-keys (lis-ht &key (test 'equal))
19 
+  (reduce (op (union _ _ :test test))
20 
+	  lis-ht
21 
+	  :key #'hash-table-keys))
22 
+
23 
+(defun tabulate (lis-ht stream)
24 
+  (let ((keys (get-all-keys lis-ht)))
25 
+    (format stream "~&~{~a~}~%~{~{~a~}~%~}"
26 
+	    (intersperse #\tab keys)
27 
+	    (mapcar (op (intersperse #\tab (pick keys _)))
28 
+		    lis-ht))))
29 
+
30 
+(net.didierverna.clon:defsynopsis (:postfix "FILE")
31 
+  (text :contents "Read in a json array and print a table"))
32 
+
33 
+(defun main ()
34 
+  (net.didierverna.clon:make-context)
35 
+  (let ((rem (net.didierverna.clon:remainder)))
36 
+    (if (null (cdr rem))
37 
+	(with-input-from-file (s (car rem))
38 
+	  (tabulate (yason:parse s) t))
39 
+	(error "only one arg allowed"))))
40 
+
41 
+
42 
+(defun build ()
43 
+  (net.didierverna.clon:dump "json-tabulator" main))
jsonarr_to_table.lisp
History View file @ 1a481a6
0 44 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+(defpackage json-to-table
2 
+  (:use :cl :alexandria :serapeum :fw.lu))
mpd-protocol.lisp
History View file @ 1a481a6
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+(defpackage :mpd-protocol
2 
+  (:use :cl :alexandria :serapeum :esrap)
3 
+  (:shadowing-import-from :string-case :string-case))
4 
+
5 
+(in-package :mpd-protocol)
6 
+
7 
+(progn (defparameter *the-sock* (usocket:socket-connect "127.0.0.1" 6600))
8 
+       (get-line))
9 
+
10 
+(defparameter *buffer* (make-array 100 :element-type '(unsigned-byte 8)))
11 
+
12 
+(defun get-line ()
13 
+  (read-line (usocket:socket-stream *the-sock*) nil))
14 
+
15 
+(defun send-command (command &rest args)
16 
+  (write-line (string-join (list* command args) #\space)
17 
+	      (usocket:socket-stream *the-sock*))
18 
+  (finish-output (usocket:socket-stream *the-sock*))
19 
+  (loop for line = (get-line)
20 
+     while (and line (string/= line "OK"))
21 
+       collect line))
postscript-interp.lisp
History View file @ 1a481a6
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,37 @@
1 
+(defpackage :lispostscript
2 
+  (:use :cl :alexandria :serapeum))
3 
+(in-package :lispostscript)
4 
+
5 
+(defclass operator ()
6 
+  ())
7 
+
8 
+(defclass environment ()
9 
+  ((&operators :initarg :operators :initform (make-hash-table))
10 
+   (&parent :initarg :parent :initform nil)))
11 
+
12 
+(defgeneric op-stack-size (operator))
13 
+
14 
+(defgeneric lookup-name (environment name)
15 
+  (:method-combination append))
16 
+
17 
+(defmethod)
18 
+
19 
+(defgeneric execute-op (op &rest args)
20 
+  )
21 
+
22 
+(defun un-rpn (list environment)
23 
+  (loop with stack = (list)
24 
+     for token in list
25 
+     if (and (symbolp token)
26 
+	     (not (keywordp token)))
27 
+     do (let ((op (lookup-name environment token)))
28 
+	  (typecase op
29 
+	    (operator (let ((op-call (list)))
30 
+			(dotimes (n (op-stack-size op))
31 
+			  (push (pop stack) op-call))
32 
+			(push op stack)
33 
+			(push 'execute-op stack)))
34 
+	    (t (push op stack))))
35 
+     else do (push token stack)
36 
+     finally (return stack)))
37 
+
promise-chaining.lisp
History View file @ 1a481a6
0 38 
new file mode 100644
... ... 
@@ -0,0 +1,23 @@
1 
+(ql:quickload :parenscript)
2 
+
3 
+(defpackage :parenscript-chaining
4 
+  (:use :cl :parenscript))
5 
+
6 
+(in-package :parenscript-chaining)
7 
+
8 
+(defclass promise ()
9 
+  ())
10 
+(defgeneric then (promise cb))
11 
+
12 
+(defmacro+ps with-promise ((result-sym promise-form) &body body)
13 
+  (let ((promise-sym (gensym)))
14 
+    `(let* ((,promise-sym ,promise-form)
15 
+            ,@(loop for form in body
16 
+                    collect `(,promise-sym ((@ ,promise-sym then) (lambda (,result-sym) ,form)))))
17 
+       ,promise-sym)))
18 
+
19 
+
20 
+(ps
21 
+  (with-promise (val (chain window (fetch "/http/google.com")))
22 
+    (chain val (json))
23 
+    (@ val "success")))
shape-drawing.lisp
History View file @ 1a481a6
0 24 
new file mode 100644
... ... 
@@ -0,0 +1,25 @@
1 
+
2 
+(defclass shape ()
3 
+  ())
4 
+
5 
+(defclass positioned-obect ()
6 
+  ((%by :accessor by :initarg :by :initform 0)
7 
+   (%lx :accessor lx :initarg :lx :initform 0)
8 
+   (%shape :accessor shape :initarg :shape
9 
+           :initform (error "a positioned object needs a shape"))))
10 
+
11 
+(defgeneric lx (shape))
12 
+(defgeneric by (shape))
13 
+(defgeneric width (shape))
14 
+(defgeneric height (shape))
15 
+
16 
+(defgeneric bounding-box (shape)
17 
+  (:documentation "Get the bounding box for a shape return a pair (#(LX BY) . #(W H))"))
18 
+
19 
+(defclass rect ()
20 
+  ((%width :accessor width :initarg width :initform 0)
21 
+   (%height :accessor height :initarg height :initform 0)))
22 
+
23 
+(defmethod bounding-box ((rect rect))
24 
+  (cons (vector (lx rect) (by rect))
25 
+        (vector (width rect) (height rect))))
spinneret-dynamic-tags.lisp
History View file @ 1a481a6
0 26 
new file mode 100644
... ... 
@@ -0,0 +1,38 @@
1 
+(eval-when (:load-toplevel)
2 
+  (ql:quickload '(:macrodynamics :spinneret :alexandria)))
3 
+
4 
+(defpackage #:spinneret-dynamic-tags
5 
+  (:use :cl :alexandria))
6 
+(in-package #:spinneret-dynamic-tags)
7 
+
8 
+(macrodynamics:def-dynenv-var **heading-level** 1)
9 
+(macrodynamics:def-dynenv-fun make-heading (text attrs)
10 
+  (let ((heading (make-keyword (format nil "H~d" (clamp **heading-level** 1 6)))))
11 
+    `(,heading ,@attrs ,text)))
12 
+
13 
+(macrodynamics:def-dynenv-macro with-heading (title (&rest attrs) &body body &environment env)
14 
+  `(spinneret:with-html
15 
+     (:section ,@attrs ,(make-heading title (list))
16 
+	       ,(macrodynamics:ct-let ((**heading-level** (1+ **heading-level**)))
17 
+		  `(progn ,@body)))))
18 
+
19 
+(spinneret:deftag division (body attrs &key (title (error "A division needs a :title")))
20 
+  `(with-heading ,title (,@attrs)
21 
+     ,@body))
22 
+
23 
+(spinneret:deftag checkbox (body attrs)
24 
+  `(let ((id (gensym "ID")))
25 
+     (:div.checkbox-container :id (format nil "~a-container" id)
26 
+       (:input :type "checkbox" :name id :id id)
27 
+       (:label :for id ,@attrs ,@body))))
28 
+
29 
+(spinneret:deftag with-scoped-styles (((&rest styles) &rest body) attrs &key (id-sym 'id))
30 
+  `(let ((,id-sym (gensym "STYLE-SCOPE")))
31 
+     (:style
32 
+      (lass:write-sheet
33 
+       (lass:compile-sheet
34 
+	`(,(format nil "#~a" ,id-sym) ,@(loop for style in ,styles
35 
+					     collect `(quote ,style))))
36 
+       :stream spinneret:*html*))
37 
+     (:div :id ,id-sym ,@attrs
38 
+	   ,@body)))
ssh-configurator.lisp
History View file @ 1a481a6
0 39 
new file mode 100644
... ... 
@@ -0,0 +1,115 @@
1 
+(defpackage :ssh-configurator
2 
+  (:use :clim :clim-lisp))
3 
+(in-package :ssh-configurator)
4 
+
5 
+(defclass host ()
6 
+  ((%hosts :initarg :hosts :reader hosts)
7 
+   (%options :initarg :options :reader options)))
8 
+(defclass ssh-config ()
9 
+  ((%hosts :initarg :hosts :reader hosts)
10 
+   (%options :initarg :options :reader options)))
11 
+
12 
+(defgeneric read-in (file object)
13 
+  (:method ((path string) object)
14 
+    (read-in (pathname path) object))
15 
+  (:method ((path pathname) object)
16 
+    (alexandria:with-input-from-file (f path)
17 
+      (read-in f object))))
18 
+
19 
+(defmethod read-in (file (host-blocks))
20 
+  )
21 
+
22 
+(defun prefix-count-if (pred seq)
23 
+  (length (serapeum:take-while pred seq)))
24 
+
25 
+(defun read-indented-block (stream)
26 
+  (values (loop for line = (read-line stream nil)
27 
+             for next-char = (peek-char nil stream nil)
28 
+             for whitespace-count = (prefix-count-if #'serapeum:whitespacep line)
29 
+             when (< whitespace-count (length line)) collect
30 
+               (cons whitespace-count
31 
+                     (subseq line whitespace-count))
32 
+             while (and next-char
33 
+                        (serapeum:whitespacep next-char)))
34 
+          stream))
35 
+
36 
+(defun tokenize-block (block)
37 
+  (mapcar (alexandria:compose 'serapeum:tokens
38 
+                              'cdr)
39 
+          block))
40 
+
41 
+(defun read-all-indented-blocks (stream)
42 
+  (loop for block = (read-indented-block stream)
43 
+     while block
44 
+     collect block))
45 
+
46 
+(define-application-frame ssh-configurator ()
47 
+  ((host-blocks :initarg :host-blocks :accessor host-blocks
48 
+                :initform (error "need host blocks...")))
49 
+  (:panes
50 
+   (hosts (make-pane 'list-pane :items (host-blocks *application-frame*)))
51 
+   (props (make-pane 'list-pane :items '(2 3 41 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18))))
52 
+  (:layouts
53 
+   (default (vertically ()
54 
+              (scrolling ()
55 
+                hosts)
56 
+              (scrolling ()
57 
+                props))))
58 
+  )
59 
+
60 
+
61 
+(defun ssh-configurator (host-blocks)
62 
+  (fw.lu:prog1-bind (f (make-application-frame 'ssh-configurator
63 
+                                               :host-blocks host-blocks))
64 
+    (bt:make-thread
65 
+     (serapeum:op (run-frame-top-level f))
66 
+     :name "ssh-configurator")))
67 
+
68 
+(defmacro print-and-return-when ((condition) form &rest others)
69 
+  `(let ((result ,form))
70 
+     (when ,condition
71 
+       (format *trace-output* "~&Result is: ~s~%~4t(~{~s~^ ~})~%" result (list ,@others)))
72 
+     result))
73 
+
74 
+(defun get-all-subclasses (object)
75 
+  (print-and-return-when ((typep (car result) 'standard-class))
76 
+   (etypecase object
77 
+     (list (mapcar 'get-all-subclasses object))
78 
+     (null (princ :what?))
79 
+     (symbol (get-all-subclasses (find-class object)))
80 
+     ((or standard-class sb-mop:funcallable-standard-class)
81 
+      (list (class-name object)
82 
+            (get-all-subclasses (sb-mop:class-direct-subclasses object)))))
83 
+   ))
84 
+
85 
+(defpackage :ssh-configurator/t
86 
+  (:use :cl :should-test))
87 
+(in-package :ssh-configurator/t)
88 
+(import 'ssh-configurator::read-indented-block)
89 
+
90 
+(deftest read-indented-block ()
91 
+    ()
92 
+  (should be equal
93 
+          '((0 . "a b c") (4 . "d"))
94 
+          (with-input-from-string (s (format nil "a b c~%~4td"))
95 
+            (read-indented-block s)))
96 
+  (should be equal
97 
+          '((0 . "e f g") (4 . "h"))
98 
+          (with-input-from-string (s (format nil "a b c~%~4td~%e f g~%~4th"))
99 
+            (read-indented-block
100 
+             (nth-value 1 (read-indented-block s)))))
101 
+  (should be equal
102 
+          '((0 . "e f g") (4 . "h"))
103 
+          (with-input-from-string (s (format nil "a b c~%~4td~%e f g~%~4th~%  "))
104 
+            (read-indented-block
105 
+             (nth-value 1 (read-indented-block s)))))
106 
+  (should be equal
107 
+          nil
108 
+          (with-input-from-string (s (format nil ""))
109 
+            (read-indented-block
110 
+             (nth-value 1 (read-indented-block s)))))
111 
+  (should be equal
112 
+          nil
113 
+          (with-input-from-string (s (format nil "   "))
114 
+            (read-indented-block
115 
+             (nth-value 1 (read-indented-block s))))))
state-machine.lisp
History View file @ 1a481a6
0 116 
new file mode 100644
... ... 
@@ -0,0 +1,29 @@
1 
+(defpackage :fwoar.state
2 
+  (:use :cl))
3 
+
4 
+(defun state-machine ()
5 
+  (declare (optimize (debug 3)))
6 
+  (labels
7 
+      ((backslash (char))
8 
+       (open-parens (char)
9 
+	 (case char
10 
+	   (#\) (list (list :paren) 'default t t))
11 
+	   (t (list (list :char char) 'open-parens nil t))))
12 
+       (quote% (char))
13 
+       (default (char)
14 
+	 (case char
15 
+	   (#\( (list (list :paren) 'open-parens nil t))
16 
+	   (t (list (list :char char) 'default nil t)))))
17 
+    (loop with state = 'default
18 
+       with result = (make-array 10 :adjustable t :fill-pointer 0)
19 
+       for next-char = (peek-char nil *standard-input* nil :eof)
20 
+       for (out next-state finished advance) = (funcall state next-char)
21 
+       until (or finished (eq next-char :eof) (null next-state))
22 
+       when advance do
23 
+	 (read-char *standard-input* nil :eof)
24 
+       when out do
25 
+	 (vector-push-extend out result)
26 
+       do
27 
+	 (setf state next-state)
28 
+       finally
29 
+	 (return result))))
timer.lisp
History View file @ 1a481a6
0 30 
new file mode 100644
... ... 
@@ -0,0 +1,17 @@
1 
+(defpackage :timer
2 
+  (:use :clim-lisp :clim)
3 
+  (:export ))
4 
+(in-package :timer)
5 
+
6 
+(define-application-frame timer ()
7 
+  ((time :initform 300))
8 
+  (:pointer-documentation t)
9 
+  (:panes (app :application :display-function 'display-timer :height 200 :width 600)
10 
+          (int :interactor :height 200 :width 600))
11 
+  (:layouts
12 
+   (default (vertically ()
13 
+              app int))))
14 
+
15 
+(defun display-timer (frame pane)
16 
+  (with-text-style (pane '(:fixed :bold 18))
17 
+    (format pane "hello!")))
tip-calc-other.lisp
History View file @ 1a481a6
0 18 
new file mode 100644
... ... 
@@ -0,0 +1,85 @@
1 
+(in-package :cl-user)
2 
+
3 
+(defmacro quickloads (&rest r)
4 
+  `(progn
5 
+     ,@(loop for x in r
6 
+             collect `(ql:quickload ,x))))
7 
+
8 
+(quickloads
9 
+  :cl-actors
10 
+  :cells
11 
+  :contextl)
12 
+
13 
+(defpackage :math-test
14 
+  (:use :cl :cl-actors :cells))
15 
+
16 
+(in-package :math-test)
17 
+
18 
+(defmacro push-many (place &body items)
19 
+  `(progn ,@(loop for item in items
20 
+                  collect `(push ,item ,place))))
21 
+
22 
+(defmodel service-rating ()
23 
+          ((rating :cell t :accessor rating :initarg :rating :initform (c-in :normal))
24 
+           (rate   :cell t :accessor rate   :initform (c? (case (rating self)
25 
+                                                            (:normal 0.18)
26 
+                                                            (:excellent 0.25)
27 
+                                                            (:poor 0.15))))))
28 
+
29 
+(defmodel tip-calc ()
30 
+          ((cost :cell t :accessor cost :initarg :cost :initform (c-in 0))
31 
+           (rate :cell t :accessor rate :initarg :rate :initform (c-in 0.18))
32 
+           (tip  :cell t :accessor tip  :initform (c? (* (cost self)
33 
+                                                         (rate self))))))
34 
+
35 
+(defmodel item ()
36 
+          ((kind :cell t :accessor kind :initarg :kind :initform (c-in :food))
37 
+           (cost :cell t :accessor cost :initarg :cost :initform (c-in 0))))
38 
+
39 
+(defmodel bill ()
40 
+          ((items :accessor items :initarg :items :initform (c-in nil))
41 
+           (cost  :accessor cost  :initform (c? (apply #'+
42 
+                                                       (loop for item in (items self)
43 
+                                                             collect (cost item)))))))
44 
+
45 
+(defmodel meal-expense-calculator ()
46 
+          ((subtotal :accessor subtotal :initarg :subtotal :initform (c-in 0))
47 
+           (tax-rate :accessor tax-rate :initarg :tax-rate :initform (c-in 0.08))
48 
+           (tip      :accessor tip      :initarg :tip      :initform (c-in 0))
49 
+           (total    :accessor total    :initform (c? (+   (subtotal self)
50 
+                                                           (* (tax-rate self)
51 
+                                                              (subtotal self))
52 
+                                                           (tip self))))))
53 
+
54 
+#|
55 
+ |(defobserver tip ((self tip-calc))
56 
+ |             (when old-value-boundp
57 
+ |               (format t "The tip is: ~a~%It changed by: ~a~%" new-value (- new-value
58 
+ |                                                                            old-value))))
59 
+ |
60 
+ |#
61 
+
62 
+(defun main (&rest r)
63 
+  (let* ((s-r (make-instance 'service-rating))
64 
+         (bill (make-instance 'bill))
65 
+         (tc (make-instance 'tip-calc :cost (c? (cost bill)) :rate (c? (rate s-r))))
66 
+         (meal-calc (make-instance 'meal-expense-calculator
67 
+                                   :subtotal (c? (cost bill))
68 
+                                   :tip      (c? (tip tc)))))
69 
+
70 
+    (push-many (items bill)
71 
+               (make-instance 'item :kind :meatloaf :cost 12.99)
72 
+               (make-instance 'item :kind :salmon :cost 14.99)
73 
+               (make-instance 'item :kind :frenchfries :cost 3.99)
74 
+               (make-instance 'item :kind :tomatosoup :cost 3.99)
75 
+               (make-instance 'item :kind :burgundy :cost 8.99)
76 
+               (make-instance 'item :kind :icedtea :cost 3.99))
77 
+    (setf (rating s-r) :excellent)
78 
+
79 
+    (format t "~{~a~20t~a~%~}------------------------------~%Subtotal:~20t~a~%Tax:~20t~a~%Tip:~20t~a~%Total:~20t~a~%"
80 
+            (loop for item in (items bill)
81 
+                  append (list (kind item) (cost item)))
82 
+            (subtotal meal-calc)
83 
+            (* 0.08 (subtotal meal-calc))
84 
+            (tip tc)
85 
+            (total meal-calc))))
transform-ct.lisp
History View file @ 1a481a6
0 86 
new file mode 100644
... ... 
@@ -0,0 +1,133 @@
1 
+(ql:quickload '(:plump
2 
+		:lquery
3 
+		:serapeum
4 
+		:alexandria
5 
+		:flexi-streams
6 
+		:chipz
7 
+		:babel
8 
+		:net.didierverna.clon))
9 
+
10 
+(in-package #:org.shirakumo.plump.parser)
11 
+(define-tag-dispatcher (script *tag-dispatchers* *html-tags*)
12 
+    (name)
13 
+    (string-equal name "script")
14 
+  (let* ((closing (consume))
15 
+         (attrs
16 
+          (if (char= closing #\ )
17 
+              (prog1 (read-attributes) (setf closing (consume)))
18 
+              (make-attribute-map))))
19 
+    (case closing
20 
+      (#\/ (advance) (make-element *root* "script" :attributes attrs))
21 
+      (#\>
22 
+       (let ((*root* (make-fulltext-element *root* "script" :attributes attrs)))
23 
+         (make-text-node *root*
24 
+                         (consume-until
25 
+                          (make-matcher
26 
+                           (or (is "</script>") (is "</SCRIPT>")))))
27 
+         (advance-n 9)
28 
+         *root*)))))
29 
+
30 
+(in-package :cl-user)
31 
+(defpackage :ct-transform
32 
+  (:use :cl :lquery :serapeum :alexandria :net.didierverna.clon))
33 
+(in-package :ct-transform)
34 
+
35 
+(defvar *version* "0.001")
36 
+(defsynopsis (:postfix "FILE")
37 
+  (group (:header "Generic options")
38 
+         (flag :short-name "v" :long-name "version"
39 
+               :description "Show the program version")
40 
+         (flag :short-name "h" :long-name "help"
41 
+               :description "Show this help")))
42 
+
43 
+
44 
+(defvar *txt* nil "The parsed HTML")
45 
+(defvar *fn* nil "The file to be pulled in")
46 
+(defvar *lookup-table* (make-hash-table :test 'equalp))
47 
+
48 
+;; (uiop:directory-files "." (uiop:merge-pathnames* (make-pathname :type "bz2") uiop:*wild-file*))
49 
+
50 
+(defun call-with-decompressed-text (fn cb &optional (encoding :iso-8859-1))
51 
+  (with-input-from-file (s fn :element-type '(unsigned-byte 8))
52 
+    (let* ((decompressing-stream (chipz:make-decompressing-stream 'chipz:bzip2 s))
53 
+	   (flexi-stream (flexi-streams:make-flexi-stream decompressing-stream :external-format encoding)))
54 
+      (unwind-protect (funcall cb flexi-stream)
55 
+	(close flexi-stream)
56 
+	(close decompressing-stream)))))
57 
+
58 
+(defun lookup-ref (p q a &rest r)
59 
+  (gethash (format nil "~aq.~da.~d~{~a~}" (string-upcase p) q a r)
60 
+	   *lookup-table*))
61 
+
62 
+(defun translate-book-ref (ref)
63 
+  (string-case ref
64 
+    ("" :st)
65 
+    ("CG" :scg)
66 
+    (t (make-keyword ref))))
67 
+
68 
+(defun normalize-ref (ref)
69 
+  (destructuring-bind (book . ref) (split-sequence #\, ref)
70 
+    (if ref
71 
+	(setf ref (string-join ref ","))
72 
+	(setf ref book
73 
+	      book ""))
74 
+    (values (string-join (split-sequence #\space ref
75 
+					 :remove-empty-subseqs t))
76 
+	    (translate-book-ref (remove-if-not #'upper-case-p
77 
+					       (string-capitalize book))))))
78 
+
79 
+
80 
+(defun help ())
81 
+(defun show-version ()
82 
+  (format t "~&~a~%" *version*))
83 
+
84 
+(declaim (ftype (function () nil) to-top))
85 
+(defun to-top ())
86 
+(defmacro mark-start (&body body)
87 
+  (with-gensyms (start)
88 
+    `(tagbody
89 
+	,start
90 
+	(flet ((to-top () (go ,start)))
91 
+	  ,@body))))
92 
+
93 
+(defun transform-ct-main ()
94 
+  (make-context)
95 
+  (mark-start
96 
+    (restart-case
97 
+	(cond
98 
+	  ((getopt :long-name "help") (help))
99 
+	  ((getopt :long-name "version") (show-version))
100 
+	  (t (let ((file (car (remainder)))
101 
+		   (ofile (cadr (remainder)))
102 
+		   (*package* (find-package 'ct-transform)))
103 
+	       (lquery:initialize (call-with-decompressed-text file #'plump:parse))
104 
+	       (map 'list
105 
+		    (op (destructuring-bind (ref el) _
106 
+			  (setf (gethash (multiple-value-list (normalize-ref ref))
107 
+					 *lookup-table*)
108 
+				(plump:text el))))
109 
+		    ($ "p[title]" (combine (attr :title) (node))))
110 
+
111 
+	       (let ((*print-case* :downcase))
112 
+		 (alexandria:with-output-to-file (*standard-output* ofile)
113 
+		   (loop for (ref book) being the hash-keys in *lookup-table* using (hash-value text)
114 
+		      do (print `(ref ,book ,ref
115 
+				      ,text)))))
116 
+	       ;; (alexandria:with-input-from-file (s *fn* :external-format :iso-8859-1)
117 
+	       ;;   (setf *txt* (plump:parse s)))
118 
+
119 
+	       ;; (uiop:directory-files "." (uiop:merge-pathnames* (make-pathname :type "bz2") uiop:*wild-file*))
120 
+	       ;; (car *)
121 
+	       ;; (plump:parse *)
122 
+	       ;; (lquery:initialize *)
123 
+	       ;; ($ "p[title]" (combine (attr :title)
124 
+	       ;; 			    (text)))
125 
+
126 
+	       )))
127 
+      (retry () (to-top))
128 
+      (abort ()))))
129 
+
130 
+(defun make-executable ()
131 
+  (dump "transform-ct" transform-ct-main
132 
+        :compression 8
133 
+        :purify t))
type.lisp
History View file @ 1a481a6
0 134 
new file mode 100644
... ... 
@@ -0,0 +1,13 @@
1 
+(defpackage :the-type
2 
+  (:use :cl))
3 
+(in-package :the-type)
4 
+
5 
+(defclass environment ()
6 
+  ((%vars :initarg :vars :initform (make-hash-table))
7 
+   (%)))
8 
+
9 
+(dolist (item list result)
10 
+  item)
11 
+
12 
+(defun format-dolist (dolist-form)
13 
+  kj)