new file mode 100644

@@ -0,0 +1,11 @@

+(progn

+  (defparameter *loads* ())

+  (defparameter *load-depth* 0)

+  (ccl:advise asdf:operate

+              (let ((current-load (list)))

+                (incf *load-depth*)

+                (push (cons *load-depth* arglist)

+                      *loads*)

+                (unwind-protect (:do-it)

+                  (decf *load-depth*)))

+              :when :around))

new file mode 100644

@@ -0,0 +1,48 @@

+(defun homedir-translation (input dd)

+  (declare (ignore dd))

+  (merge-pathnames

+   (make-pathname :directory

+                  (list* :relative

+                         "build-cache"

+                         "homedir"

+                         (cdr

+                          (pathname-directory

+                           (parse-namestring

+                            (enough-namestring input

+                                               (user-homedir-pathname))))))

+                  :defaults input)

+   (merge-pathnames "asdf-corral/Contents/Resources/"

+                    (user-homedir-pathname))))

+

+(defun do-translation (input dd)

+  (declare (ignore dd))

+  (merge-pathnames

+   (make-pathname :directory

+                  (list :relative

+                        "build-cache"

+                        "root"

+                        (format nil "~{~a~^-~}"(cdr (pathname-directory input))))

+                  :defaults input)

+   (merge-pathnames "asdf-corral/Contents/Resources/"

+                    (user-homedir-pathname))))

+

+(defun in-homedir ()

+  (merge-pathnames (make-pathname :directory (list :relative :wild-inferiors)

+                                  :name :wild

+                                  :type :wild

+                                  :version :wild)

+                   (user-homedir-pathname)))

+

+(asdf:initialize-output-translations

+ `(:output-translations

+   :ignore-inherited-configuration

+   :disable-cache

+   (,(in-homedir) (:function homedir-translation))

+   ("/" (:function do-translation))))

+

+(load "~/quicklisp/setup.lisp")

+

+(eval-when (:compile-toplevel :load-toplevel :execute)

+  (trace homedir-translation do-translation))

+

+(ql:quickload :data-lens)

new file mode 100644

@@ -0,0 +1,142 @@

+(defpackage :fwoar.bodge-like

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.bodge-like)

+

+(defclass feature ()

+  ((%sym :reader sym :initarg sym)))

+

+(defclass monster (feature)

+  ((%position :accessor pos :initform (gamekit:vec2 (random 12)

+                                                    (random 12)))))

+

+(defclass dog (monster)

+  ()

+  (:default-initargs sym "d"))

+

+(defun monster (sym)

+  (make-instance 'monster 'sym sym))

+

+(defclass player (feature)

+  ((%position :accessor pos :initform (gamekit:vec2 0 0)))

+  (:default-initargs sym "@"))

+

+(defparameter *white* (gamekit:vec4 1 1 1 1))

+(defparameter *black* (gamekit:vec4 0 0 0 0.8))

+(defparameter *tile-size* 32)

+

+(gamekit:defgame bodgelike ()

+  ((%player :reader player :initform (make-instance 'player))

+   (%monsters :accessor monsters :initform ()))

+  (:viewport-title "@")

+  (:viewport-height (* 12 *tile-size*))

+  (:viewport-width (* 12 *tile-size*)))

+

+(defun draw-tile (row col &optional (size *tile-size*))

+  (gamekit:draw-rect (gamekit:vec2 (* row size)

+                                   (* col size))

+                     size size

+                     :fill-paint *black*))

+

+(defvar *my-font*)

+(defun draw-feature (feature &optional pos (tile-size *tile-size*))

+  (let* ((pos (if pos

+                  pos

+                  (pos feature)))

+         (row (gamekit:x pos))

+         (col (gamekit:y pos))

+         (tile-origin (gamekit:vec2 (* row tile-size)

+                                    (* col tile-size)))

+         (feature-text (etypecase feature

+                         (string feature)

+                         (feature (sym feature)))))

+    (multiple-value-bind (text-origin text-width text-height)

+        (gamekit:calc-text-bounds feature-text *my-font*)

+      (let ((text-origin

+              (gamekit:add tile-origin

+                           (gamekit:mult -1 text-origin)

+                           (gamekit:mult 0.5

+                                         (gamekit:subt (gamekit:vec2 tile-size tile-size)

+                                                       (gamekit:vec2 text-width text-height))))))

+        (gamekit:draw-text feature-text text-origin

+                           :fill-color *white*

+                           :font *my-font*)))))

+

+

+(gamekit:define-font :fantasy "/tmp/foo/font.ttf")

+

+

+(defgeneric interact2 (game obj1 obj2)

+  (:method (game obj1 obj2) nil)

+  (:method (game obj1 obj2) t)

+  (:method (game (obj1 player) (obj2 dog))

+    (format t "~&Ruff! ~s~%" (gamekit:subt (pos obj2)

+                                           (pos obj1)))

+    (setf (pos obj2)

+          (gamekit:add (pos obj2)

+                       (gamekit:subt (pos obj2)

+                                     (pos obj1))))

+    nil))

+

+(defun find-in-space (pos obj-list)

+  (find pos obj-list 

+        :key 'pos 

+        :test 'bodge-math:vec=))

+

+(defun update (thing fun &rest args)

+  (apply fun thing args))

+

+(define-modify-macro updatef (fun &rest args)

+  update)

+

+(defun move-handler (delta)

+  (lambda (game player)

+    (updatef (pos player)

+             (lambda (old-pos)

+               (let* ((new-pos (gamekit:add old-pos delta))

+                      (feature-in-space (find-in-space new-pos (monsters game))))

+                 (if (and feature-in-space (interact2 game player feature-in-space))

+                     old-pos

+                     new-pos))))) )

+

+(defun move-left (game player)

+  (let ((handler (move-handler (gamekit:vec2 -1 0))))

+    (lambda ()

+      (funcall handler game player))))

+

+(defun move-right (game player)

+  (let ((handler (move-handler (gamekit:vec2 1 0)))) 

+    (lambda ()

+      (funcall handler game player))))

+

+(defun move-up (game player)

+  (let ((handler (move-handler (gamekit:vec2 0 1)))) 

+    (lambda ()

+      (funcall handler game player))))

+

+(defun move-down (game player)

+  (let ((handler (move-handler (gamekit:vec2 0 -1)))) 

+    (lambda ()

+      (funcall handler game player))))

+

+

+(defmethod gamekit:post-initialize ((game bodgelike))

+  (gamekit:bind-button :h :pressed

+                       (move-left game (player game)))

+  (gamekit:bind-button :j :pressed

+                       (move-down game (player game)))

+  (gamekit:bind-button :k :pressed

+                       (move-up game (player game)))

+  (gamekit:bind-button :l :pressed

+                       (move-right game (player game))))

+

+(defmethod style )

+

+(defmethod gamekit:draw ((system bodgelike))

+  (dotimes (row 16)

+    (dotimes (col 16)

+      (draw-tile row col)))

+  (let ((*my-font* (gamekit:make-font :fantasy (* 0.8 *tile-size*))))

+    (mapcar 'draw-feature

+            (monsters system))

+    (draw-feature (player system))))

new file mode 100644

@@ -0,0 +1,30 @@

+(defpackage :fwoar.condorcet

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.condorcet)

+

+(defmacro define-data-class (name (&rest super-classes) &body slots)

+  `(defclass ,name ,super-classes

+     ,(mapcar

+       (lambda (slot-name)

+         `(,slot-name :initarg ,(alexandria:make-keyword slot-name) :reader ,slot-name))

+       slots)))

+

+(define-data-class ballot ()

+  voter-name confirmation rankings)

+

+(define-data-class ranking ()

+  rank candidates)

+

+(define-data-class secret-ballot ()

+  confirmation rankings)

+

+(define-data-class tally-election-request ()

+  election candidates eligible-voters ballots)

+

+(define-data-class tally-election-response ()

+  election candidates voted did-not-vote rankings ballots preference-matrix strongest-path-matrix)

+

+(define-data-class tally-election-response ()

+  election candidates voted did-not-vote rankings ballots)

+

new file mode 100644

@@ -0,0 +1,30 @@

+(defpackage :fwoar.docstrings

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.docstrings)

+

+(eval-when (:load-toplevel :compile-toplevel :execute)

+  (defun docstring (name &key signature return summary examples doc)

+    (format nil "(~s ~{~s~^ ~}) => ~s ~a~%~%~:[~;~:*~a~%~%~]~{(~/pprint-linear/)~%~}"

+            name signature return summary

+            doc

+            examples)))

+

+(defmacro document (definition (=> return) &body (doc &rest examples))

+  (assert (eql => '=>))

+  (ecase (car definition)

+    (defun (destructuring-bind (_ name arguments summary &rest __) definition

+             (declare (ignore _ __))

+             `(progn ,definition

+                     (setf (documentation ',name 'function)

+                           ,(docstring name :signature arguments :return return :summary summary :examples examples :doc doc)))))))

+

+(document

+    (defun this-is-a-test (a b c)

+      "this is a test"

+      (declare (ignore a b c))

+      (values))

+    (=> values)

+  "don't do nothin"

+  (this-is-a-test 1 2 3)

+  (this-is-a-test 'a 2 3))

new file mode 100644

@@ -0,0 +1,133 @@

+(defpackage :fwoar.graphql

+  (:import-from :data-lens :key :over :juxt)

+  (:import-from :serapeum :defalias)

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.graphql)

+

+#|

+;; query {

+;;   search(query: "topic:common-lisp", type: REPOSITORY, first: 100) {

+;;     edges {

+;;       node {

+;;         ... on Repository {

+;;           owner {

+;;             login

+;;           }

+;;           name

+;;           description 

+;;           pushedAt

+;;         }

+;;       }

+;;     }

+;;   }

+;; }

+|#

+

+(defun camelize (name)

+  (fw.lu:with (parts (fwoar.string-utils:split #\- (string-downcase name)))

+    (format nil "~a~{~:(~a~)~}"

+            (elt parts 0)

+            (map 'list #'string-capitalize (subseq parts 1)))))

+

+(defun handle-term (term)

+  (typecase term

+    (symbol (camelize term))

+    (t term)))

+

+(defun sexp->query (s expr)

+  (destructuring-bind (op &rest body) expr

+    (pprint-logical-block (s nil)

+      (pprint-logical-block (s nil)

+        (pprint-indent :block 4 s)

+        (if (listp op)

+            (format s "~a(~{~a~^, ~})"

+                    (handle-term (car op))

+                    (loop for (key value) on (cdr op) by #'cddr

+                          collect (format nil "~a:~a" (handle-term key) value)))

+            (princ (handle-term op) s))

+        (princ " {" s)

+        (loop for expr in body

+              do

+                 (pprint-newline :mandatory s)

+              if (listp expr) do

+                (sexp->query s expr)

+              else do

+                (princ (handle-term expr)

+                       s)))

+      (pprint-newline :mandatory s)

+      (format s "}"))))

+

+(defun dive (&rest keys)

+  (lambda (map)

+    (declare (dynamic-extent map))

+    (fw.lu:dive keys map)))

+

+(defalias <>

+  'alexandria:compose)

+

+(defun %jq (&rest query)

+  (lambda (map)

+    (reduce (lambda (acc next)

+              (typecase next

+                (list (ecase (car next)

+                        (:juxt (funcall (apply 'juxt

+                                               (mapcar '%jq

+                                                       (cdr next)))

+                                        acc))

+                        (:dive (funcall (apply '%jq (cdr next))

+                                        acc))

+                        (:map (funcall (over (apply '%jq (cdr next)))

+                                       acc))))

+                (t (gethash next acc))))

+            query

+            :initial-value map)))

+

+(defmacro jq (&rest query)

+  `(%jq ,@(mapcar (lambda (v) `',v)

+                  query)))

+

+(defun format-results (results)

+  (format t "~:{* ~a/~a ~a~%~2t~a~%~%~}"

+          results))

+

+

+;; .data.search.edges[]

+;; | .node

+;; | "* "+ .owner.login + "/" + .name + " " + .pushedAt + "\n  " + .description + "\n"'

+

+(defalias extract-data

+  (jq "data"

+      "search"

+      "edges"

+      (:map "node"

+            (:juxt (:dive "owner"

+                          "login")

+                   "name"

+                   "pushedAt"

+                   "description"))))

+

+(defun search-for-topic-repos (topic)

+  `(query ((search query ,(format nil "\"topic:~a\"" topic)

+                   type "REPOSITORY"

+                   first "100")

+           (edges

+            (node

+             ("... on Repository"

+              (owner login)

+              name

+              description

+              pushed-at))))))

+

+(defun github-graphql (token query)

+  (let ((drakma:*text-content-types* (acons "application" "json"

+                                            drakma:*text-content-types*)))

+    (yason:parse (drakma:http-request "https://api.github.com/graphql"

+                                      :method :post 

+                                      :content   (yason:with-output-to-string* ()

+                                                   (yason:with-object ()

+                                                     (yason:encode-object-element

+                                                      "query"

+                                                      (with-output-to-string (s)

+                                                        (sexp->query s query)))))

+                                      :additional-headers `(("Authorization" . ,(format nil "bearer ~a" token)))))))

new file mode 100644

@@ -0,0 +1,29 @@

+(defpackage :paredit

+  (:use :cl)

+  (:export ))

+(in-package :paredit)

+

+(defclass cursor ()

+  ((%pos :initarg :pos :reader pos)))

+

+(defun make-cursor (&rest path)

+  (make-instance 'cursor

+                 :pos (copy-seq path)))

+

+(defun get-exp-at-cursor (cursor exp)

+  (reduce (lambda (acc next-pos)

+            (elt acc next-pos))

+          (pos cursor)

+          :initial-value exp))

+

+(defun barf-backward (cursor exp)

+  (let* ((parent-exp-cursor (apply 'make-cursor

+                                   (butlast (pos cursor))))

+         (parent-exp (get-exp-at-cursor parent-exp-cursor exp))

+         (grandparent-exp-cursor (apply 'make-cursor

+                                        (butlast (pos parent-exp-cursor)))))

+    

+

+

+

+    ))

new file mode 100644

@@ -0,0 +1,57 @@

+;; from Rosetta code, with modifications https://rosettacode.org/wiki/Password_generator#Common_Lisp

+(defpackage :fwoar.password-gen

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.password-gen)

+

+(defparameter *lowercase*

+  '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p

+    #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))

+

+(defparameter *uppercase*

+  '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P

+    #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))

+

+(defparameter *numbers*

+  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

+

+(defparameter *special-characters*

+  '(#\! #\\ #\# #\% #\& #\* #\+ #\, #\- #\. #\: #\< #\= #\>

+    #\? #\^ #\_ #\| #\~))

+

+(defparameter *similar-characters*

+  '(#\I #\l #\1 #\| #\O #\0 #\5 #\S #\2 #\Z))

+

+(defun make-readable (s)

+  (remove-if (lambda (x) (member x *similar-characters*)) s))

+

+(defun shuffle-list (input-list)

+  (loop with l = (length input-list)

+        for i below l

+        do (rotatef (nth i input-list)

+                    (nth (random l) input-list)))

+  input-list)

+

+(defun generate-password (len human-readable)

+  (let*

+      ((upper (if human-readable (make-readable *uppercase*) *uppercase*))

+       (lower (if human-readable (make-readable *lowercase*) *lowercase*))

+       (number (if human-readable (make-readable *numbers*) *numbers*))

+       (special (if human-readable (make-readable *special-characters*) *special-characters*))

+       (character-groups (list upper lower number special))

+       (initial-password (reduce (lambda (acc x)

+                                   (cons (nth (random (length x)) x) acc))

+                                 character-groups :initial-value NIL)))

+    

+    (coerce (shuffle-list (reduce (lambda (acc x)

+                                    (declare (ignore x))

+                                    (let ((group (nth (random (length character-groups)) character-groups)))

+                                      (cons (nth (random (length group)) group) acc)))

+                                  (make-list (- len 4)) :initial-value initial-password)) 'string)))

+

+(defun main (len count &optional human-readable)

+  (if (< len 4)

+      (print "Length must be at least 4~%")

+      (loop for x from 1 to count do

+        (princ (generate-password len human-readable))

+        (terpri))))

new file mode 100644

@@ -0,0 +1,52 @@

+(defpackage :fwoar.recursion-schemes

+  (:use :cl)

+  (:export ))

+(in-package :fwoar.recursion-schemes)

+

+(defun cdr* (cons)

+  (funcall (cdr cons)))

+

+;; cata :: (a -> b -> b) -> b -> [a] -> b

+(defun cata (fun init as)

+  (if (null as)

+      init

+      (funcall fun

+               (car as)

+               (cata fun init

+                     (cdr as)))))

+

+;; para :: (a -> [a] -> b -> b) -> b -> [a] -> b

+(defun para (fun init as)

+  (if (null as)

+      init

+      (funcall fun (car as) (cdr as)

+               (para fun init (cdr as)))))

+

+;; ana :: (v -> (a, () -> b)) -> b -> [a]

+(defun ana (fun init)

+  (destructuring-bind (a init*)

+      (funcall fun init)

+    (cons a (lambda () (ana fun init*)))))

+

+;; ana :: (v -> Maybe (a, b)) -> b -> [a]

+(defun ana* (fun init)

+  (let ((v (funcall fun init)))

+    (when v

+      (cons (car v)

+            (ana* fun (cadr v))))))

+

+;; hylo  :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c

+(defun hylo (reducer reducer-init generator generator-seed)

+  (flet ((partial-ana (init)

+           (ana* generator init)))

+    (cata reducer reducer-init

+          (partial-ana generator-seed))))

+

+;; zygo (a -> b -> b) -> (a -> b -> c -> c) -> b -> c -> [a] -> c

+(defun zygo (fold-1 fold-2 fold-1-init fold-2-init as)

+  (second

+   (cata (fw.lu:destructuring-lambda (x (p q))

+           (list (funcall fold-1 x p)

+                 (funcall fold-2 x p q)))

+         (list fold-1-init fold-2-init)

+         as)))

new file mode 100644

@@ -0,0 +1,16 @@

+(defpackage :sqlite-environment

+  (:use :cl )

+  (:export ))

+(in-package :sqlite-environment)

+

+(defparameter *sqlite-env* (list))

+

+(defmacro defun* (name (&rest args) &body body)

+  `(progn

+     (push '(list ,name ,args ,body)

+           *sqlite-env*)

+     (defun ,name ,args

+       ,@body)))

+

+(defun* do-thing ()

+  (asdf))

new file mode 100644

@@ -0,0 +1,33 @@

+(defpackage :fwoar.triangle

+  (:use :cl )

+  (:export ))

+(in-package :fwoar.triangle)

+

+(defun alternate-source ()

+  (let ((alternator t))

+    (lambda ()

+      (prog1 alternator

+        (setf alternator (not alternator))))))

+

+(defun print-triangle (size)

+  (let ((alt (alternate-source)))

+    (dotimes (n size)

+      (let ((count (1+ n)))

+        (dotimes (i count)

+          (format t "~:[0~;1~] " (funcall alt)))

+        (terpri)))))

+

+#|

+TRIANGLE> (print-triangle 11)

+1

+0 1

+0 1 0

+1 0 1 0

+1 0 1 0 1

+0 1 0 1 0 1

+0 1 0 1 0 1 0

+1 0 1 0 1 0 1 0

+1 0 1 0 1 0 1 0 1

+0 1 0 1 0 1 0 1 0 1

+0 1 0 1 0 1 0 1 0 1 0

+|#