common lisp
Table of Contents
- 1. Dawn of the Era
- 2. Fulci
- 3. cl-18n
- 4. cl-pslib
- 5. cl-kanren
- 6. Nodgui
- 7. Tinmop
- 8. Ltk tips
- 9. Exercises from Programming praxis
- 10. 99 lisp problems
- 10.1. 1
- 10.2. 2
- 10.3. 3
- 10.4. 4
- 10.5. 5
- 10.6. 6
- 10.7. 7
- 10.8. 8
- 10.9. 9
- 10.10. 10
- 10.11. 11
- 10.12. 12
- 10.13. 13
- 10.14. 14
- 10.15. 15
- 10.16. 16
- 10.17. 17
- 10.18. 18
- 10.19. 19
- 10.20. 20
- 10.21. 21
- 10.22. 22
- 10.23. 23
- 10.24. 24
- 10.25. 25
- 10.26. 26
- 10.27. 27
- 10.28. 28
- 10.29. 31
- 10.30. 32
- 10.31. 33
- 10.32. 34
- 10.33. 35
- 10.34. 36
- 10.35. 37
- 10.36. 38
- 10.37. 39
- 10.38. 40
- 10.39. 41
- 10.40. 46
- 10.41. 47
- 10.42. 48
- 10.43. 49-50
- 10.44. 54a
- 10.45. 55
- 10.46. 56
- 10.47. 57
- 10.48. 58
- 10.49. 59
- 10.50. 60
- 10.51. 61
- 10.52. 61a
- 10.53. 62
- 10.54. 62b
- 10.55. 63
- 10.56. 64
- 10.57. 65
- 10.58. 66
- 10.59. 67
- 10.60. 68
- 10.61. 69
- 10.62. 90
- 10.63. 91
- 10.64. 92
- 10.65. 95
- 10.66. 97
- 10.67. 98
1 Dawn of the Era
3 cl-18n
I am the current maintainer of the cl-i18n library; an internationalization library for common lisp.
4 cl-pslib
7 Tinmop
8 Ltk tips
I found using Ltk a wise choise for GUI programming. Below you can find some little code snippets.
8.1 Bind function to a canvas element
(asdf:operate 'asdf:load-op 'ltk) (use-package 'ltk) (defun bind-red (e) (declare (ignore e)) (do-msg "click on red!")) (defun bind-green (e) (declare (ignore e)) (do-msg "click on green!")) (with-ltk () (let* ((size 500) (canvas (make-canvas nil :width size :height size)) (arc1 (create-arc canvas (/ size 4) (/ size 4) (* size 3/4) (* size 3/4) :start 0 :extent 180)) (arc2 (create-arc canvas (/ size 4) (/ size 4) (* size 3/4) (* size 3/4) :start 180 :extent 180))) (itemconfigure canvas arc1 "fill" "#ff0000") (itemconfigure canvas arc2 "fill" "#00ff00") (itemconfigure canvas arc1 "tag" "red") (itemconfigure canvas arc2 "tag" "green") (tagbind canvas "red" "<ButtonPress-1>" #'bind-red) (tagbind canvas "green" "<ButtonPress-1>" #'bind-green) (pack canvas)))
8.2 Draw an arrow at ends of an arc
(asdf:operate 'asdf:load-op 'ltk) (defpackage :arrow (:use :cl :ltk)) (in-package :arrow) (defun deg->rad (deg) (/ (* deg (* 2 pi)) 360)) (defun rotate-point (x y angle) (values (- (* x (cos angle)) (* y (sin angle))) (+ (* x (sin angle)) (* y (cos angle))))) (defun main (angle &key (draw-center->end nil)) (with-ltk () (let* ((canvas (make-canvas nil :width 640 :height 480)) (arr-x-start 0) (arr-y-start 0) (arr-x-end 20) (arr-y-end 20) (bb-x-start 100) (bb-y-start 100) (bb-x-end 240) (bb-y-end 340) (rangle (deg->rad (- angle))) (x-center (+ bb-x-start (/ (- bb-x-end bb-x-start) 2))) (y-center (+ bb-y-start (/ (- bb-y-end bb-y-start) 2))) (a-axe (- bb-x-end x-center)) (b-axe (- bb-y-end y-center)) (arc-x-end (* a-axe (cos rangle))) (arc-y-end (* b-axe (sin rangle)))) (create-arc canvas bb-x-start bb-y-start bb-x-end bb-y-end :style "arc" :extent angle) (let ((h1 (create-line* canvas x-center y-center (+ x-center a-axe) y-center)) (h2 (create-line* canvas x-center y-center x-center (+ y-center b-axe)))) (itemconfigure canvas h1 "fill" "#ff0000") (itemconfigure canvas h2 "fill" "#00ff00")) (when draw-center->end (let ((h3 (create-line* canvas x-center y-center (+ x-center arc-x-end) (+ y-center arc-y-end)))) (itemconfigure canvas h3 "fill" "#ff00ff"))) (multiple-value-bind (xrot-start yrot-start) (rotate-point arr-x-start arr-y-start rangle) (multiple-value-bind (xrot-end yrot-end) (rotate-point arr-x-end arr-y-end rangle) (incf xrot-start (+ x-center arc-x-end)) (incf yrot-start (+ y-center arc-y-end)) (incf xrot-end (+ x-center arc-x-end)) (incf yrot-end (+ y-center arc-y-end)) (create-line* canvas xrot-start yrot-start xrot-end yrot-end))) (multiple-value-bind (xrot-start yrot-start) (rotate-point arr-x-start arr-y-start (+ (deg->rad 90) rangle)) (multiple-value-bind (xrot-end yrot-end) (rotate-point arr-x-end arr-y-end (+ (deg->rad 90) rangle)) (setf arr-x-start xrot-start) (setf arr-y-start yrot-start) (setf arr-x-end xrot-end) (setf arr-y-end yrot-end) (incf arr-x-start (+ x-center arc-x-end)) (incf arr-y-start (+ y-center arc-y-end)) (incf arr-x-end (+ x-center arc-x-end)) (incf arr-y-end (+ y-center arc-y-end))) (create-line* canvas arr-x-start arr-y-start arr-x-end arr-y-end)) (pack canvas))))
9 Exercises from Programming praxis
Some solutions for problems founds on programming praxis
9.1 Tribonacci Numbers
;; tribonacci sequence ;; Copyright (C) 2012 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. (defmacro matrix-elt (mat row col) `(nth ,col (nth ,row ,mat))) (defun column@ (mat at) (mapcar #'(lambda (r) (nth at r)) mat)) (defun m-mult (a b) (let ((res (loop for i from 0 below (length a) collect (make-list (length (first b)))))) (loop for i from 0 below (length a) do (loop for j from 0 below (length (first b)) do (setf (matrix-elt res i j) (reduce #'+ (mapcar #'* (nth i a) (column@ b j)) :initial-value 0)))) res)) (defun m-pow (a exp &optional (base (copy-tree a))) (if (> exp 2) (m-pow (m-mult a base) (1- exp) base) (m-mult a base))) (defun nth-fibonacci (n) (if (= n 0) 0 (matrix-elt (m-pow '((1 1) (1 0)) (- n 1)) 1 0))) (defun nth-tribonacci (n) (cond ((= n 0) 0) ((= n 1) 1) (t (matrix-elt (m-pow '((1 1 0) (1 0 1) (1 0 0)) (1- n)) 0 2)))) (defun tribonacci-real (n &optional (res (list 1 0 0))) (if (= 0 n) (reverse res) (tribonacci-real (- n 1) (push (+ (first res) (second res) (third res)) res)))) (defun tribonacci (n) (cond ((= n 0) nil) ((= n 1) (list 0)) ((= n 2) (list 0 1)) ((= n 3) (list 0 0 1)) (t (tribonacci-real (- n 3))))) (defun tribonacci-ratio (n) (float (/ (nth-tribonacci n) (nth-tribonacci (1- n)))))
9.2 Random Access Lists
From the excellent: Purely Functional Data Structures, Chris Okasaki Cambrige Press 1998
;; skew binary number random access list ;; Copyright (C) 2012 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. (defclass btree () ((value :initarg :value :accessor value) (left :initarg :left :initform nil :accessor left) (right :initarg :right :initform nil :accessor right))) (defmethod print-object ((object btree) stream) (with-slots (value left right) object (format stream " <value ~a left ~a right ~a> " value left right))) (defgeneric leaf-p (object)) (defgeneric lookup-tree (object w pos)) (defgeneric update-tree (object w pos value)) (defmethod leaf-p ((object btree)) (and (null (left object)) (null (right object)))) (defmethod lookup-tree ((object btree) (w integer) (pos integer)) (cond ((= pos 0) (value object)) (t (if (< pos (/ w 2)) (lookup-tree (left object) (truncate (/ w 2)) (- pos 1)) (lookup-tree (right object) (truncate (/ w 2)) (- pos 1 (truncate (/ w 2)))))))) (defmethod update-tree ((object btree) (w integer) (pos integer) value) (cond ((= pos 0) (make-instance 'btree :value value :left (left object) :right (right object))) (t (if (< pos (/ w 2)) (make-instance 'btree :value (value object) :left (update-tree (left object) (truncate (/ w 2)) (- pos 1) value) :right (right object)) (make-instance 'btree :value (value object) :left (left object) :right (update-tree (right object) (truncate (/ w 2)) (- pos 1 (truncate (/ w 2))) value)))))) (defun scons (val slist) (cond ((null slist) (list (list 1 (make-instance 'btree :value val)))) ((= (length slist) 1) (cons (list 1 (make-instance 'btree :value val)) slist)) ((= (first (first slist)) (first (second slist))) (let ((w1 (first (first slist))) (w2 (first (second slist))) (tree-left (second (first slist))) (tree-right (second (second slist)))) (cons (list (+ w1 w2 1) (make-instance 'btree :value val :left tree-left :right tree-right)) (subseq slist 2)))) (t (cons (list 1 (make-instance 'btree :value val)) slist)))) (defun shead (slist) (if (null slist) nil (value (second (first slist))))) (defmacro with-weight-and-node ((w node slist) &body body) `(let ((,node (second (first ,slist))) (,w (first (first ,slist)))) ,@body)) (defun stail (slist) (with-weight-and-node (w node slist) (if (leaf-p node) (rest slist) (cons (list (truncate (/ w 2)) (left node)) (cons (list (truncate (/ w 2)) (right node)) (rest slist)))))) (defun lookup (pos slist) (if (null slist) nil (with-weight-and-node (w node slist) (if (< pos w) (lookup-tree node w pos) (lookup (- pos w) (rest slist)))))) (defun update (pos value slist) (if (null slist) nil (with-weight-and-node (w node slist) (if (< pos w) (cons (update-tree node w pos value) (rest slist)) (cons (first slist) (update (- pos w) value (rest slist)))))))
9.3 Hash Tables With Open Addressing
;; simple open addressing hashtable ;; Copyright (C) 2012 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. (asdf:load-system :alexandria) (alexandria:define-constant +hashtable-size+ 10 :test #'=) (defun hash (string) (if (string/= string "") (let ((first-char (char-code (elt string 0)))) (mod (+ first-char (hash (subseq string 1))) +hashtable-size+)) 0)) (defclass hashnode () ((key :initform nil :accessor key :initarg :key :type 'string) (datum :initform nil :accessor datum :initarg :datum) (status :initform :empty :accessor status :initarg :status))) (defmethod print-object ((object hashnode) stream) (with-slots (key datum status) object (print-unreadable-object (object stream :type nil :identity t) (format stream "key: ~s datum: ~a status: ~a" key datum status)))) (defparameter *hashtable* '()) (defun h-initialize () (setf *hashtable* (loop for i from 0 below +hashtable-size+ collect (make-instance 'hashnode)))) (defun h-add-datum (key datum &optional (address (hash key)) (count 0)) (if (< count +hashtable-size+) (if (or (eq (status (nth address *hashtable*)) :empty) (eq (status (nth address *hashtable*)) :deleted) (string= key (key (nth address *hashtable*)))) (progn (format t "address ~a (key ~a) empty~%" address key) (setf (datum (nth address *hashtable*)) datum) (setf (key (nth address *hashtable*)) key) (setf (status (nth address *hashtable*)) :occupied)) (progn (format t "collision for address ~a (key ~a) collide with ~a~%" address key (nth address *hashtable*)) (h-add-datum key datum (mod (1+ address) +hashtable-size+) (1+ count)))) (error "hashtable full for key ~s" key))) (defun h-lookup (key &optional (address (hash key)) (count 0)) (if (< count +hashtable-size+) (let ((node@address (nth address *hashtable*))) (if (not (eq (status node@address) :empty)) (if (string= (key node@address) key) (values (datum node@address) address) (h-lookup key (mod (1+ address) +hashtable-size+) (1+ count))) nil)) nil)) (defun h-delete (key) (multiple-value-bind (found address) (h-lookup key) (if found (let ((node@address (nth address *hashtable*))) (setf (datum node@address) nil) (setf (key node@address) nil) (setf (status node@address) :deleted)) nil))) (defun test-hashtable () (h-initialize) (loop for i in '("a" "b" "c" "d" "d" "e" "f" "g" "h" "i" "m") and d = 0 then (1+ d) do (format t "add ~a -> ~a~%" i d) (h-add-datum i d) (format t "~a~%" *hashtable*)) (format t "delete m key ~a ~%" (hash "m")) (h-delete "m") (format t "~a~%" *hashtable*) (format t "re add m key ~a ~%" (hash "m")) (h-add-datum "m" 11) (format t "~a~%" *hashtable*) (format t "delete c key ~a ~%" (hash "c")) (h-delete "c") (format t "~a~%" *hashtable*) (format t "delete m key ~a ~%" (hash "m")) (h-delete "m") (format t "~a~%" *hashtable*))
9.4 4SUM
An inefficient solution.
(defun n-tuple (input &optional (count (length input))) (let ((res '())) (labels ((actual-n-tuple (input &optional (count (length input)) (accum '())) (if (> count 0) (mapcar #'(lambda (a) (actual-n-tuple input (1- count) (append accum (list a)))) input) (push accum res)))) (actual-n-tuple input count) res))) (defun 4sum (input) (if (or (every #'(lambda (a) (< a 0)) input) (every #'(lambda (a) (> a 0)) input)) nil (remove-if #'(lambda (v) (not (= (reduce #'+ v) 0))) (n-tuple input 4))))
9.5 Minimum Scalar Product
(defun min-scalar (a b) (reduce #'+ (mapcar #'(lambda (v1 v2) (* v1 v2)) (sort a #'<) (sort b #'>))))
9.6 Make
;; simplicistic build system ;; Copyright (C) 2012 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. (asdf:load-system :alexandria) (asdf:load-system :osicat) (asdf:load-system :cl-lex) (asdf:load-system :yacc) (asdf:load-system :trivial-shell) (defparameter *debug* t) (defmacro define-stat-time (slot-name) (alexandria:with-gensyms (stat) `(defun ,(alexandria:format-symbol t "~:@(get-stat-~a~)" slot-name) (file) (restart-case (let ((,stat (nix:stat file))) (if ,stat (,(alexandria:format-symbol :nix "~:@(stat-~a~)" slot-name) ,stat))) (use-value (value) value))))) (define-stat-time mtime) (define-stat-time ctime) (define-stat-time atime) (defun file-outdated-p (file &rest dependencies) (handler-bind ((nix:enoent #'(lambda (c) (declare (ignore c)) (invoke-restart 'use-value nil)))) (let ((atime (get-stat-atime file)) (mtimes (remove-if #'null (mapcar #'get-stat-mtime dependencies)))) (when *debug* (format t "file ~a ~a ~a ~a~%" file atime dependencies mtimes)) (if atime (remove-if #'(lambda (mtime) (<= mtime atime)) mtimes) t)))) (defclass rule () ((name :initform nil :accessor name :initarg :name) (dependencies :initform '() :accessor dependencies :initarg :dependencies) (commands :initform '() :accessor commands :initarg :commands))) (defparameter *all-rules* '()) (defun find-dependency (rule-name &optional (all-rules *all-rules*)) (find-if #'(lambda (dep) (string= (name dep) rule-name)) all-rules)) (defmethod print-object ((object rule) stream) (format stream "name ~a dep ~a cmds ~a" (name object) (dependencies object) (commands object))) (defgeneric build (object)) (defmethod build ((object rule)) (let ((commands-trigger (cond ((not (osicat:file-exists-p (name object))) t) ((dependencies object) nil) (t t)))) (loop for i in (dependencies object) do (let ((dep (find-dependency i))) (if dep (let ((trigger (build dep))) (when trigger (setf commands-trigger trigger))) (when (file-outdated-p (name object) i) (setf commands-trigger t))))) (when commands-trigger (if *debug* (format t "rule: ~a~%~{~a~%~}~%~%" (name object) (commands object)) (mapc #'(lambda (cmd) (format t "~a~%~{~a~}~%" cmd (subseq (multiple-value-list (metashell:shell-command cmd)) 0 2))) (commands object)))) commands-trigger)) (defmethod build ((rule string)) (build (find-dependency rule))) (cl-lex:define-string-lexer lexer ("\\t(.*)" (return (values 'command $1))) ("([a-z,0-9,_,\\-,\\.]+):" (return (values 'name $1))) ("([a-z,0-9,_,\\-,\\.]+) " (return (values 'dependency $1))) ("([a-z,0-9,_,\\-,\\.]+)\\n" (return (values 'terminal-dependency $1)))) ;; make := rule* ;; rule := name dependencies* terminal-dependency command* (yacc:define-parser *make-parser* (:start-symbol make) (:terminals (name dependency terminal-dependency command)) (make rules nil) (rules (rule rules) rule) (rule (name dep stopper commands #'(lambda (name dependency terminal-dependency command) (push (make-instance 'rule :name name :dependencies (alexandria:flatten (append dependency (list terminal-dependency))) :commands (alexandria:flatten command)) *all-rules*)))) (dep (dependency dep) dependency nil) (stopper terminal-dependency nil) (commands (command commands) command) (dependency) (command) (name) (terminal-dependency)) (defun read-file (file) (with-open-file (stream file :direction :input) (do ((lines "")) (nil) (handler-case (setf lines (concatenate 'string lines (format nil "~%") (read-line stream))) (end-of-file (c) (declare (ignore c)) (return lines)))))) (defun make (root-rule &optional (file "Makefile")) (yacc:parse-with-lexer (lexer (read-file file)) *make-parser*) (build root-rule))
9.7 SEND + MORE = MONEY, Part 2
;; cryptarithm solver with hill-climbing algorithm ;; Copyright (C) 2012 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. (eval-when (:execute) (setf *random-state* (make-random-state t))) (defparameter *all-letters-values* (make-hash-table :test 'equal)) (defparameter *all-letters*