common lisp

(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)))

(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))))

;; 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)))))

;; 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)))))))

;; 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*))

(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))))

(defun min-scalar (a b)
  (reduce #'+ (mapcar #'(lambda (v1 v2) (* v1 v2))
                      (sort a #'<)
                      (sort b #'>))))

;; 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))

;; 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