From abaine at common-lisp.net Thu Aug 2 15:31:16 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 11:31:16 -0400 (EDT)
Subject: [funds-cvs] r102 - trunk/funds/src/trees
Message-ID: <20070802153116.79B937E0A9@common-lisp.net>
Author: abaine
Date: Thu Aug 2 11:31:15 2007
New Revision: 102
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Added function stitch-avl-nodes to replace attach-avl.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 11:31:15 2007
@@ -36,9 +36,9 @@
(defun balance (inside root outside &key heavy-side)
(let ((other-side (other-side heavy-side)))
(if (balanced-p inside outside)
- (attach-avl root
- heavy-side outside
- other-side inside)
+ (stitch-avl-nodes :root root
+ heavy-side outside
+ other-side inside)
(rotate inside root
(if (heavier-p outside :side other-side)
(rotate (tree-child outside :side heavy-side)
@@ -50,13 +50,20 @@
(defun rotate (inside root outside &key side)
(let* ((t1 (tree-child outside :side side))
- (new-inside (attach-avl root
- side inside
- (other-side side) t1))
+ (new-inside (stitch-avl-nodes :root root
+ side inside
+ (other-side side) t1))
(new-outside (tree-child outside :side (other-side side))))
- (attach-avl outside
- side new-inside
- (other-side side) new-outside)))
+ (stitch-avl-nodes :root outside
+ side new-inside
+ (other-side side) new-outside)))
+
+(defun stitch-avl-nodes (&key root (key (bt-key root)) (value (bt-value root))
+ left right)
+ (make-instance 'avl-tree
+ :key key :value value
+ :left left :right right
+ :height (parent-height left right)))
(defun attach-avl (root &key (right (make-avl-tree)) (left (make-avl-tree)))
(make-avl-tree :key (bt-key root)
From abaine at common-lisp.net Thu Aug 2 15:35:59 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 11:35:59 -0400 (EDT)
Subject: [funds-cvs] r103 - trunk/funds/src/trees
Message-ID: <20070802153559.E99404D053@common-lisp.net>
Author: abaine
Date: Thu Aug 2 11:35:58 2007
New Revision: 103
Modified:
trunk/funds/src/trees/avl.lisp
trunk/funds/src/trees/tree-insert.lisp
Log:
Added default left and right keywords in stitch-avl-nodes.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 11:35:58 2007
@@ -59,7 +59,7 @@
(other-side side) new-outside)))
(defun stitch-avl-nodes (&key root (key (bt-key root)) (value (bt-value root))
- left right)
+ (left (make-avl-leaf)) (right make-avl-leaf))
(make-instance 'avl-tree
:key key :value value
:left left :right right
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Thu Aug 2 11:35:58 2007
@@ -33,8 +33,8 @@
(defmethod tree-insert ((tree avl-leaf) key value &key test order)
(declare (ignore test order))
- (make-avl-tree :key key
- :value value))
+ (stitch-avl-tree :key key
+ :value value))
(defmethod tree-insert ((tree binary-tree) key value
&key (test #'eql) (order #'<))
From abaine at common-lisp.net Thu Aug 2 15:37:49 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 11:37:49 -0400 (EDT)
Subject: [funds-cvs] r104 - trunk/funds/src/trees
Message-ID: <20070802153749.277BC4D053@common-lisp.net>
Author: abaine
Date: Thu Aug 2 11:37:48 2007
New Revision: 104
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Renamed stitch-avl-tree.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 11:37:48 2007
@@ -36,7 +36,7 @@
(defun balance (inside root outside &key heavy-side)
(let ((other-side (other-side heavy-side)))
(if (balanced-p inside outside)
- (stitch-avl-nodes :root root
+ (stitch-avl-tree :root root
heavy-side outside
other-side inside)
(rotate inside root
@@ -50,15 +50,15 @@
(defun rotate (inside root outside &key side)
(let* ((t1 (tree-child outside :side side))
- (new-inside (stitch-avl-nodes :root root
+ (new-inside (stitch-avl-tree :root root
side inside
(other-side side) t1))
(new-outside (tree-child outside :side (other-side side))))
- (stitch-avl-nodes :root outside
+ (stitch-avl-tree :root outside
side new-inside
(other-side side) new-outside)))
-(defun stitch-avl-nodes (&key root (key (bt-key root)) (value (bt-value root))
+(defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root))
(left (make-avl-leaf)) (right make-avl-leaf))
(make-instance 'avl-tree
:key key :value value
From abaine at common-lisp.net Thu Aug 2 15:39:02 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 11:39:02 -0400 (EDT)
Subject: [funds-cvs] r105 - trunk/funds/src/trees
Message-ID: <20070802153902.4EA9950029@common-lisp.net>
Author: abaine
Date: Thu Aug 2 11:39:01 2007
New Revision: 105
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Deleted attach-avl and make-avl-node, which are obviated by stitch-avl-tree.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 11:39:01 2007
@@ -64,17 +64,3 @@
:key key :value value
:left left :right right
:height (parent-height left right)))
-
-(defun attach-avl (root &key (right (make-avl-tree)) (left (make-avl-tree)))
- (make-avl-tree :key (bt-key root)
- :value (bt-key root)
- :right right
- :left left))
-
-(defun make-avl-node (&key key value (left make-avl-tree) (right make-avl-tree))
- (make-instance 'avl-tree
- :key key
- :value value
- :left left
- :right right
- :height (parent-height left right)))
From abaine at common-lisp.net Thu Aug 2 15:41:44 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 11:41:44 -0400 (EDT)
Subject: [funds-cvs] r106 - trunk/funds/src/trees
Message-ID: <20070802154144.1EBE161052@common-lisp.net>
Author: abaine
Date: Thu Aug 2 11:41:43 2007
New Revision: 106
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Cosmetic.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Thu Aug 2 11:41:43 2007
@@ -47,8 +47,8 @@
(if (tree-empty-p temp)
(make-avl-tree)
(let* ((heavy-side (if (heavier-p temp :side :left)
- :left
- :right))
+ :left
+ :right))
(inside (tree-child temp :side (other-side heavy-side)))
(outside (tree-child temp :side heavy-side)))
(balance inside temp outside :heavy-side heavy-side)))))
From abaine at common-lisp.net Thu Aug 2 16:14:22 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 12:14:22 -0400 (EDT)
Subject: [funds-cvs] r107 - trunk/funds/src/trees
Message-ID: <20070802161422.799AA1C0BA@common-lisp.net>
Author: abaine
Date: Thu Aug 2 12:14:20 2007
New Revision: 107
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Corrected nesting problem.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 12:14:20 2007
@@ -59,7 +59,7 @@
(other-side side) new-outside)))
(defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root))
- (left (make-avl-leaf)) (right make-avl-leaf))
+ (left (make-avl-leaf)) (right (make-avl-leaf)))
(make-instance 'avl-tree
:key key :value value
:left left :right right
From abaine at common-lisp.net Thu Aug 2 16:14:58 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 12:14:58 -0400 (EDT)
Subject: [funds-cvs] r108 - trunk/funds/src/trees
Message-ID: <20070802161458.DDE511C0BA@common-lisp.net>
Author: abaine
Date: Thu Aug 2 12:14:58 2007
New Revision: 108
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Corrected make-avl-tree to stitch-avl-tree.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Thu Aug 2 12:14:58 2007
@@ -55,10 +55,10 @@
(defmethod tree-insert ((tree avl-tree) key value
&key (test #'eql) (order #'<))
(if (funcall test key (bt-key tree))
- (make-avl-tree :key key
- :value value
- :left (bt-left tree)
- :right (bt-right tree))
+ (stitch-avl-tree :key key
+ :value value
+ :left (bt-left tree)
+ :right (bt-right tree))
(let* ((temp (call-next-method))
(side (side-to-insert tree key :order order))
(outside (tree-child temp :side side))
From abaine at common-lisp.net Thu Aug 2 19:35:52 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 15:35:52 -0400 (EDT)
Subject: [funds-cvs] r109 - trunk/funds/src/trees
Message-ID: <20070802193552.20F953E053@common-lisp.net>
Author: abaine
Date: Thu Aug 2 15:35:51 2007
New Revision: 109
Modified:
trunk/funds/src/trees/bt.lisp
Log:
Deleted attach-bt.
Modified: trunk/funds/src/trees/bt.lisp
==============================================================================
--- trunk/funds/src/trees/bt.lisp (original)
+++ trunk/funds/src/trees/bt.lisp Thu Aug 2 15:35:51 2007
@@ -33,13 +33,6 @@
(f (bt-left tree)))))
(f (bt-right tree))))
-(defun attach-bt (root &key left right)
- (make-instance 'binary-tree
- :key (bt-key root)
- :value (bt-value root)
- :left left
- :right right))
-
(defun side-to-insert (tree key &key order)
(if (funcall order key (bt-key tree))
:left
From abaine at common-lisp.net Thu Aug 2 19:38:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 15:38:18 -0400 (EDT)
Subject: [funds-cvs] r110 - trunk/funds/src/trees
Message-ID: <20070802193818.773DF3E053@common-lisp.net>
Author: abaine
Date: Thu Aug 2 15:38:18 2007
New Revision: 110
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Deleted avl specializer
for tree-remove because general bt method works fine; replaced attach-bt forms with
stitch-tree.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Thu Aug 2 15:38:18 2007
@@ -35,23 +35,11 @@
:left
:right))
(other-side (other-side side)))
- (attach-bt tree
- side (tree-remove (tree-child tree :side side) key
+ (stitch-tree tree
+ side (tree-remove (tree-child tree :side side) key
:test test
:order order)
- other-side (tree-child tree :side other-side)))))
-
-(defmethod tree-remove ((tree avl-tree) key &key (test #'eql) (order #'<))
- (declare (ignore test order))
- (let ((temp (call-next-method)))
- (if (tree-empty-p temp)
- (make-avl-tree)
- (let* ((heavy-side (if (heavier-p temp :side :left)
- :left
- :right))
- (inside (tree-child temp :side (other-side heavy-side)))
- (outside (tree-child temp :side heavy-side)))
- (balance inside temp outside :heavy-side heavy-side)))))
+ other-side (tree-child tree :side other-side)))))
(defun remove-root (tree &key test order)
(cond ((tree-empty-p (bt-left tree)) (bt-right tree))
@@ -60,6 +48,6 @@
(defun remove-root-with-children (tree &key test order)
(let* ((next (next-in-order tree)))
- (attach-bt next
- :left (bt-left tree)
- :right (tree-remove (bt-right tree) (bt-key next) :test test :order order))))
+ (stitch-tree next
+ :left (bt-left tree)
+ :right (tree-remove (bt-right tree) (bt-key next) :test test :order order))))
From abaine at common-lisp.net Thu Aug 2 19:40:23 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 15:40:23 -0400 (EDT)
Subject: [funds-cvs] r111 - trunk/funds/src/trees
Message-ID: <20070802194023.708347E0A9@common-lisp.net>
Author: abaine
Date: Thu Aug 2 15:40:23 2007
New Revision: 111
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Totally changed balance function
so that it doesn't require the creation of intermediate nodes.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Thu Aug 2 15:40:23 2007
@@ -33,24 +33,26 @@
(defun balanced-p (t1 t2)
(< -2 (height-difference t1 t2) 2))
-(defun balance (inside root outside &key heavy-side)
- (let ((other-side (other-side heavy-side)))
- (if (balanced-p inside outside)
- (stitch-avl-tree :root root
- heavy-side outside
- other-side inside)
- (rotate inside root
- (if (heavier-p outside :side other-side)
- (rotate (tree-child outside :side heavy-side)
- outside
- (tree-child outside :side other-side)
- :side heavy-side)
- outside)
- :side other-side))))
+(defun balance (key value left right)
+ (let ((height-difference (- (tree-height left) (tree-height right))))
+ (if (< -2 height-difference 2)
+ (stitch-avl-tree :key key :value value :left left :right right)
+ (let* ((heavy-side (if (plusp height-difference) :left :right))
+ (other-side (other-side heavy-side))
+ (inside (if (left-p heavy-side) right left))
+ (outside (if (left-p heavy-side) left right)))
+ (rotate inside key value
+ (if (heavier-p outside :side other-side)
+ (rotate (tree-child outside :side heavy-side)
+ (bt-key outside) (bt-value outside)
+ (tree-child outside :side other-side)
+ :side heavy-side)
+ outside)
+ :side other-side)))))
-(defun rotate (inside root outside &key side)
+(defun rotate (inside root-key root-value outside &key side)
(let* ((t1 (tree-child outside :side side))
- (new-inside (stitch-avl-tree :root root
+ (new-inside (stitch-avl-tree :key root-key :value root-value
side inside
(other-side side) t1))
(new-outside (tree-child outside :side (other-side side))))
From abaine at common-lisp.net Thu Aug 2 19:41:49 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 2 Aug 2007 15:41:49 -0400 (EDT)
Subject: [funds-cvs] r112 - trunk/funds/src/trees
Message-ID: <20070802194149.7E3FE7E0A9@common-lisp.net>
Author: abaine
Date: Thu Aug 2 15:41:49 2007
New Revision: 112
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Got rid of avl specializer
for tree-insert and instead made generic stitch-tree that balances tree as it is created.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Thu Aug 2 15:41:49 2007
@@ -36,31 +36,25 @@
(stitch-avl-tree :key key
:value value))
-(defmethod tree-insert ((tree binary-tree) key value
- &key (test #'eql) (order #'<))
+(defmethod tree-insert ((tree binary-tree) key value &key (test #'eql) (order #'<))
(if (funcall test key (bt-key tree))
- (make-instance 'binary-tree
- :key key
- :value value
- :left (bt-left tree)
- :right (bt-right tree))
+ (stitch-tree tree :key key :value value :left (bt-left tree) :right (bt-right tree))
(let* ((side (side-to-insert tree key :order order))
(other-side (other-side side)))
- (attach-bt tree
- side (tree-insert (tree-child tree :side side) key value
+ (stitch-tree tree
+ side (tree-insert (tree-child tree :side side) key value
:test test
:order order)
- other-side (tree-child tree :side other-side)))))
+ other-side (tree-child tree :side other-side)))))
-(defmethod tree-insert ((tree avl-tree) key value
- &key (test #'eql) (order #'<))
- (if (funcall test key (bt-key tree))
- (stitch-avl-tree :key key
- :value value
- :left (bt-left tree)
- :right (bt-right tree))
- (let* ((temp (call-next-method))
- (side (side-to-insert tree key :order order))
- (outside (tree-child temp :side side))
- (inside (tree-child temp :side (other-side side))))
- (balance inside temp outside :heavy-side side))))
+(defmethod stitch-tree ((tree binary-tree)
+ &key (key (bt-key tree)) (value (bt-value tree)) left right)
+ (make-instance 'binary-tree
+ :key key
+ :value value
+ :left left
+ :right right))
+
+(defmethod stitch-tree ((tree avl-tree)
+ &key (key (bt-key tree)) (value (bt-value tree)) left right)
+ (balance key value left right))
From abaine at common-lisp.net Sat Aug 4 14:01:12 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:01:12 -0400 (EDT)
Subject: [funds-cvs] r113 - trunk/funds/src
Message-ID: <20070804140112.3481E7E003@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:01:11 2007
New Revision: 113
Modified:
trunk/funds/src/funds.asd
Log:
Added stitch-tree to defsystem form.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Sat Aug 4 10:01:11 2007
@@ -33,6 +33,7 @@
(:file "constructors")
(:file "bt")
(:file "avl")
+ (:file "stitch-tree")
(:file "tree-as-alist")
(:file "tree-empty-p")
(:file "tree-insert")
From abaine at common-lisp.net Sat Aug 4 14:03:17 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:03:17 -0400 (EDT)
Subject: [funds-cvs] r114 - trunk/funds/src/trees
Message-ID: <20070804140317.C3DE77E003@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:03:17 2007
New Revision: 114
Added:
trunk/funds/src/trees/stitch-tree.lisp
Log:
Added stitch-tree methods and
functions to replace constructors. These are responsible for making sure that the nodes
that are stitched together actually satisfy avl properties in the case of avl trees.
Added: trunk/funds/src/trees/stitch-tree.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/trees/stitch-tree.lisp Sat Aug 4 10:03:17 2007
@@ -0,0 +1,41 @@
+
+;;;;
+;;;; Copyright 2007 Andrew Baine
+;;;;
+;;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;;; you may not use this file except in compliance with the License.
+;;;; You may obtain a copy of the License at
+;;;;
+;;;; http://www.apache.org/licenses/LICENSE-2.0
+;;;;
+;;;; Unless required by applicable law or agreed to in writing, software
+;;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;;; See the License for the specific language governing permissions and
+;;;; limitations under the License.
+;;;;
+
+(in-package :funds)
+
+(defmethod stitch-tree ((tree binary-tree)
+ &key (key (bt-key tree)) (value (bt-value tree)) left right)
+ (stitch-binary-tree :key key :value value :left left :right right))
+
+(defmethod stitch-tree ((tree avl-tree)
+ &key (key (bt-key tree)) (value (bt-value tree)) left right)
+ (balance key value left right))
+
+(defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root))
+ (left (make-avl-leaf)) (right (make-avl-leaf)))
+ (make-instance 'avl-tree
+ :key key :value value
+ :left left :right right
+ :height (parent-height left right)))
+
+(defun stitch-binary-tree (&key root (key (bt-key root)) (value (bt-value root))
+ (left (make-binary-tree)) (right (make-binary-tree)))
+ (make-instance 'binary-tree
+ :key key
+ :value value
+ :left left
+ :right right))
From abaine at common-lisp.net Sat Aug 4 14:06:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:06:56 -0400 (EDT)
Subject: [funds-cvs] r115 - trunk/funds/src/trees
Message-ID: <20070804140656.CC14F2B132@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:06:51 2007
New Revision: 115
Modified:
trunk/funds/src/trees/tree-remove.lisp
Log:
Superficial change.
Modified: trunk/funds/src/trees/tree-remove.lisp
==============================================================================
--- trunk/funds/src/trees/tree-remove.lisp (original)
+++ trunk/funds/src/trees/tree-remove.lisp Sat Aug 4 10:06:51 2007
@@ -50,4 +50,5 @@
(let* ((next (next-in-order tree)))
(stitch-tree next
:left (bt-left tree)
- :right (tree-remove (bt-right tree) (bt-key next) :test test :order order))))
+ :right (tree-remove (bt-right tree) (bt-key next)
+ :test test :order order))))
From abaine at common-lisp.net Sat Aug 4 14:14:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:14:03 -0400 (EDT)
Subject: [funds-cvs] r116 - trunk/funds/src/trees
Message-ID: <20070804141403.89EE161051@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:14:03 2007
New Revision: 116
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Changed tree-insert specializer
to no longer be a specializer. So leaves are now a special case, and tree insertion
proceeds the same for binary trees and avl trees. The difference is that anytime during
insertion or removal that a tree is 'stitched' together, stitch-tree balances an avl tree
but not a binary tree; also I moved stitch-tree functions to the stitch-tree file.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Sat Aug 4 10:14:03 2007
@@ -27,16 +27,14 @@
(defmethod tree-insert ((tree bt-leaf) key value &key test order)
(declare (ignore test order))
- (make-instance 'binary-tree
- :key key
- :value value))
+ (stitch-binary-tree :key key :value value))
(defmethod tree-insert ((tree avl-leaf) key value &key test order)
(declare (ignore test order))
- (stitch-avl-tree :key key
- :value value))
+ (stitch-avl-tree :key key :value value))
-(defmethod tree-insert ((tree binary-tree) key value &key (test #'eql) (order #'<))
+
+(defmethod tree-insert (tree key value &key (test #'eql) (order #'<))
(if (funcall test key (bt-key tree))
(stitch-tree tree :key key :value value :left (bt-left tree) :right (bt-right tree))
(let* ((side (side-to-insert tree key :order order))
@@ -46,15 +44,3 @@
:test test
:order order)
other-side (tree-child tree :side other-side)))))
-
-(defmethod stitch-tree ((tree binary-tree)
- &key (key (bt-key tree)) (value (bt-value tree)) left right)
- (make-instance 'binary-tree
- :key key
- :value value
- :left left
- :right right))
-
-(defmethod stitch-tree ((tree avl-tree)
- &key (key (bt-key tree)) (value (bt-value tree)) left right)
- (balance key value left right))
From abaine at common-lisp.net Sat Aug 4 14:16:11 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:16:11 -0400 (EDT)
Subject: [funds-cvs] r117 - in trunk/funds/src/trees: . heap
Message-ID: <20070804141611.838AB9@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:16:11 2007
New Revision: 117
Modified:
trunk/funds/src/trees/constructors.lisp
trunk/funds/src/trees/heap/heap.lisp
Log:
Moved heap constructor to heap.lisp.
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Sat Aug 4 10:16:11 2007
@@ -36,13 +36,3 @@
(defun make-avl-tree ()
(make-avl-leaf))
-(defun make-heap (&key (priority 0 p-p) value
- (left (make-heap-leaf)) (right (make-heap-leaf)))
- (if p-p
- (make-instance 'heap
- :priority priority
- :value value
- :left left
- :right right
- :weight (+ 1 (tree-weight left) (tree-weight right)))
- (make-heap-leaf)))
Modified: trunk/funds/src/trees/heap/heap.lisp
==============================================================================
--- trunk/funds/src/trees/heap/heap.lisp (original)
+++ trunk/funds/src/trees/heap/heap.lisp Sat Aug 4 10:16:11 2007
@@ -1,6 +1,17 @@
(in-package :funds)
+(defun make-heap (&key (priority 0 p-p) value
+ (left (make-heap-leaf)) (right (make-heap-leaf)))
+ (if p-p
+ (make-instance 'heap
+ :priority priority
+ :value value
+ :left left
+ :right right
+ :weight (+ 1 (tree-weight left) (tree-weight right)))
+ (make-heap-leaf)))
+
(defun attach-heap (root &key left right)
(make-heap :priority (heap-priority root)
:value (bt-value root)
From abaine at common-lisp.net Sat Aug 4 14:18:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 4 Aug 2007 10:18:29 -0400 (EDT)
Subject: [funds-cvs] r118 - trunk/funds/src/trees
Message-ID: <20070804141829.E95729@common-lisp.net>
Author: abaine
Date: Sat Aug 4 10:18:29 2007
New Revision: 118
Modified:
trunk/funds/src/trees/avl.lisp
Log:
Moved stitch-avl-tree to stitch-tree file.
Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp (original)
+++ trunk/funds/src/trees/avl.lisp Sat Aug 4 10:18:29 2007
@@ -34,7 +34,7 @@
(< -2 (height-difference t1 t2) 2))
(defun balance (key value left right)
- (let ((height-difference (- (tree-height left) (tree-height right))))
+ (let ((height-difference (height-difference left right)))
(if (< -2 height-difference 2)
(stitch-avl-tree :key key :value value :left left :right right)
(let* ((heavy-side (if (plusp height-difference) :left :right))
@@ -60,9 +60,3 @@
side new-inside
(other-side side) new-outside)))
-(defun stitch-avl-tree (&key root (key (bt-key root)) (value (bt-value root))
- (left (make-avl-leaf)) (right (make-avl-leaf)))
- (make-instance 'avl-tree
- :key key :value value
- :left left :right right
- :height (parent-height left right)))
From abaine at common-lisp.net Wed Aug 8 00:32:00 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 7 Aug 2007 20:32:00 -0400 (EDT)
Subject: [funds-cvs] r119 - trunk/funds/src
Message-ID: <20070808003200.0A0C45903E@common-lisp.net>
Author: abaine
Date: Tue Aug 7 20:32:00 2007
New Revision: 119
Modified:
trunk/funds/src/package.lisp
Log:
Added dictionary interface to exported symbols.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Tue Aug 7 20:32:00 2007
@@ -46,4 +46,9 @@
:stack-empty-p
:stack-push
:stack-top
- :stack-size))
+ :stack-size
+
+ :make-dictionary
+ :dictionary-add
+ :dictionary-remove
+ :dictionary-lookup))
From abaine at common-lisp.net Wed Aug 8 00:41:21 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 7 Aug 2007 20:41:21 -0400 (EDT)
Subject: [funds-cvs] r120 - trunk/funds/src
Message-ID: <20070808004121.6AC5B59092@common-lisp.net>
Author: abaine
Date: Tue Aug 7 20:41:15 2007
New Revision: 120
Modified:
trunk/funds/src/funds.asd
Log:
Added dictionary to defsystem.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Tue Aug 7 20:41:15 2007
@@ -48,4 +48,6 @@
(:file "heap-insert")
(:file "heap-remove")
(:file "heap-first")))))
+ (:file "dictionary")
(:file "queue")))
+
From abaine at common-lisp.net Wed Aug 8 00:49:44 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 7 Aug 2007 20:49:44 -0400 (EDT)
Subject: [funds-cvs] r121 - trunk/funds/src
Message-ID: <20070808004944.5B4F55F01E@common-lisp.net>
Author: abaine
Date: Tue Aug 7 20:49:44 2007
New Revision: 121
Added:
trunk/funds/src/dictionary.lisp
Log:
Added dictionary.lisp.
Added: trunk/funds/src/dictionary.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/dictionary.lisp Tue Aug 7 20:49:44 2007
@@ -0,0 +1,3 @@
+
+(in-package :funds)
+
From abaine at common-lisp.net Wed Aug 8 00:58:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 7 Aug 2007 20:58:03 -0400 (EDT)
Subject: [funds-cvs] r122 - trunk/funds/src
Message-ID: <20070808005803.8D98172086@common-lisp.net>
Author: abaine
Date: Tue Aug 7 20:58:03 2007
New Revision: 122
Modified:
trunk/funds/src/dictionary.lisp
Log:
Added stubs for dictionary interface.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Tue Aug 7 20:58:03 2007
@@ -1,3 +1,15 @@
(in-package :funds)
+(defstruct dict
+ hash-function
+ test-function
+ tree)
+
+(defun make-dictionary (&key hash-function test))
+
+(defun dictionary-add (dictionary key value))
+
+(defun dictionary-remove (dictionary key))
+
+(defun dictionary-lookup (dictionary key))
From abaine at common-lisp.net Wed Aug 8 02:34:25 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 7 Aug 2007 22:34:25 -0400 (EDT)
Subject: [funds-cvs] r123 - trunk/funds/src
Message-ID: <20070808023425.B221D2B127@common-lisp.net>
Author: abaine
Date: Tue Aug 7 22:34:25 2007
New Revision: 123
Modified:
trunk/funds/src/dictionary.lisp
Log:
Implimented dictionary functionality.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Tue Aug 7 22:34:25 2007
@@ -2,14 +2,38 @@
(in-package :funds)
(defstruct dict
- hash-function
- test-function
+ hash
+ test
tree)
-(defun make-dictionary (&key hash-function test))
+(defun make-dictionary (&key (hash #'sxhash) (test #'eql))
+ (make-dict :hash hash :test test :tree (make-avl-tree)))
-(defun dictionary-add (dictionary key value))
+(defun dictionary-add (d k v)
+ (let* ((h (funcall (dict-hash d) k))
+ (old-alist (tree-find (dict-tree d) h))
+ (new-alist (acons k v (remove (assoc k old-alist :test (dict-test d))
+ old-alist))))
+ (make-dict :hash (dict-hash d)
+ :test (dict-test d)
+ :tree (tree-insert (dict-tree d) h new-alist))))
-(defun dictionary-remove (dictionary key))
+(defun dictionary-remove (d k)
+ (let* ((h (funcall (dict-hash d) k))
+ (old-alist (tree-find (dict-tree d) h))
+ (new-alist (remove (assoc k old-alist :test (dict-test d))
+ old-alist)))
+ (make-dict :hash (dict-hash d)
+ :test (dict-test d)
+ :tree (if (null new-alist)
+ (tree-remove (dict-tree d) h)
+ (tree-insert (dict-tree d) h new-alist)))))
+
+(defun dictionary-lookup (d k)
+ (let ((pair (assoc k
+ (tree-find (dict-tree d) (funcall (dict-hash d) k))
+ :test (dict-test d))))
+ (if (null pair)
+ (values nil nil)
+ (values (cdr pair) t))))
-(defun dictionary-lookup (dictionary key))
From abaine at common-lisp.net Fri Aug 10 20:57:51 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 16:57:51 -0400 (EDT)
Subject: [funds-cvs] r124 - trunk/funds/src
Message-ID: <20070810205751.4FBBA2E1CF@common-lisp.net>
Author: abaine
Date: Fri Aug 10 16:57:51 2007
New Revision: 124
Modified:
trunk/funds/src/package.lisp
Log:
Added f-array interface.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Fri Aug 10 16:57:51 2007
@@ -51,4 +51,8 @@
:make-dictionary
:dictionary-add
:dictionary-remove
- :dictionary-lookup))
+ :dictionary-lookup
+
+ :make-f-array
+ :f-array-elt
+ :f-array-replace))
From abaine at common-lisp.net Fri Aug 10 20:58:13 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 16:58:13 -0400 (EDT)
Subject: [funds-cvs] r125 - trunk/funds/src
Message-ID: <20070810205813.30D742E1CF@common-lisp.net>
Author: abaine
Date: Fri Aug 10 16:58:12 2007
New Revision: 125
Modified:
trunk/funds/src/funds.asd
Log:
Added array file to defsystem form.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Fri Aug 10 16:58:12 2007
@@ -48,6 +48,7 @@
(:file "heap-insert")
(:file "heap-remove")
(:file "heap-first")))))
+ (:file "array")
(:file "dictionary")
(:file "queue")))
From abaine at common-lisp.net Fri Aug 10 21:02:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 17:02:29 -0400 (EDT)
Subject: [funds-cvs] r126 - trunk/funds/src
Message-ID: <20070810210229.97A9B2E1D8@common-lisp.net>
Author: abaine
Date: Fri Aug 10 17:02:29 2007
New Revision: 126
Added:
trunk/funds/src/f-array.lisp
Log:
Added f-array.lisp.
Added: trunk/funds/src/f-array.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/f-array.lisp Fri Aug 10 17:02:29 2007
@@ -0,0 +1,2 @@
+
+(in-package :funds)
From abaine at common-lisp.net Fri Aug 10 21:09:14 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 17:09:14 -0400 (EDT)
Subject: [funds-cvs] r127 - trunk/funds/src
Message-ID: <20070810210914.A97CE3001A@common-lisp.net>
Author: abaine
Date: Fri Aug 10 17:09:14 2007
New Revision: 127
Modified:
trunk/funds/src/f-array.lisp
Log:
Added f-array stubs.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Fri Aug 10 17:09:14 2007
@@ -1,2 +1,11 @@
(in-package :funds)
+
+(defun make-f-array (size &key (initial-contents nil))
+ )
+
+(defun f-array-elt (array index)
+ )
+
+(defun f-array-replace (array index item)
+ )
From abaine at common-lisp.net Fri Aug 10 22:14:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:14:09 -0400 (EDT)
Subject: [funds-cvs] r128 - trunk/funds/src
Message-ID: <20070810221409.429583C047@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:14:09 2007
New Revision: 128
Modified:
trunk/funds/src/funds.asd
Log:
Renamed array file to f-array.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Fri Aug 10 18:14:09 2007
@@ -48,7 +48,7 @@
(:file "heap-insert")
(:file "heap-remove")
(:file "heap-first")))))
- (:file "array")
+ (:file "f-array")
(:file "dictionary")
(:file "queue")))
From abaine at common-lisp.net Fri Aug 10 22:14:53 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:14:53 -0400 (EDT)
Subject: [funds-cvs] r129 - trunk/funds/src/trees
Message-ID: <20070810221453.4C5F93C047@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:14:53 2007
New Revision: 129
Modified:
trunk/funds/src/trees/tree-find.lisp
Log:
Corrected problem with tree-find algorithm.
Modified: trunk/funds/src/trees/tree-find.lisp
==============================================================================
--- trunk/funds/src/trees/tree-find.lisp (original)
+++ trunk/funds/src/trees/tree-find.lisp Fri Aug 10 18:14:53 2007
@@ -39,4 +39,4 @@
(cond ((funcall test key (bt-key tree)) (values (bt-value tree) t))
((funcall order key (bt-key tree)) (tree-find (bt-left tree) key
:test test :order order))
- (t (tree-find (bt-left tree) key :test test :order order))))
+ (t (tree-find (bt-right tree) key :test test :order order))))
From abaine at common-lisp.net Fri Aug 10 22:15:27 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:15:27 -0400 (EDT)
Subject: [funds-cvs] r130 - trunk/funds/src
Message-ID: <20070810221527.551FF3C047@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:15:27 2007
New Revision: 130
Modified:
trunk/funds/src/f-array.lisp
Log:
Implemented make-f-array.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Fri Aug 10 18:15:27 2007
@@ -2,7 +2,18 @@
(in-package :funds)
(defun make-f-array (size &key (initial-contents nil))
- )
+ (let ((length (length initial-contents)))
+ (labels ((f (start end)
+ (if (= start end)
+ (make-binary-tree)
+ (let ((midpoint (floor (+ end start) 2)))
+ (make-instance 'binary-tree
+ :key midpoint :value (if (< start length)
+ (elt initial-contents midpoint)
+ nil)
+ :left (f start midpoint)
+ :right (f (1+ midpoint) end))))))
+ (f 0 size))))
(defun f-array-elt (array index)
)
From abaine at common-lisp.net Fri Aug 10 22:26:44 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:26:44 -0400 (EDT)
Subject: [funds-cvs] r131 - trunk/funds/src
Message-ID: <20070810222644.371E35614D@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:26:43 2007
New Revision: 131
Modified:
trunk/funds/src/f-array.lisp
Log:
Implemented f-array-elt, f-array-replace, and f-array-size.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Fri Aug 10 18:26:43 2007
@@ -16,7 +16,14 @@
(f 0 size))))
(defun f-array-elt (array index)
- )
+ (tree-find array index :test #'=))
(defun f-array-replace (array index item)
- )
+ (tree-insert array index item :test #'=))
+
+(defun f-array-size (array)
+ (labels ((f (tree amount)
+ (if (tree-empty-p tree)
+ amount
+ (f (bt-right tree) (bt-key tree)))))
+ (f array 0)))
From abaine at common-lisp.net Fri Aug 10 22:32:47 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:32:47 -0400 (EDT)
Subject: [funds-cvs] r132 - trunk/funds/src
Message-ID: <20070810223247.16ACD7B4A6@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:32:46 2007
New Revision: 132
Modified:
trunk/funds/src/f-array.lisp
Log:
Fixed f-array-size.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Fri Aug 10 18:32:46 2007
@@ -25,5 +25,5 @@
(labels ((f (tree amount)
(if (tree-empty-p tree)
amount
- (f (bt-right tree) (bt-key tree)))))
+ (f (bt-right tree) (1+ (bt-key tree))))))
(f array 0)))
From abaine at common-lisp.net Fri Aug 10 22:33:43 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 18:33:43 -0400 (EDT)
Subject: [funds-cvs] r133 - trunk/funds/src
Message-ID: <20070810223343.2A6E07B4A6@common-lisp.net>
Author: abaine
Date: Fri Aug 10 18:33:42 2007
New Revision: 133
Modified:
trunk/funds/src/package.lisp
Log:
Exported f-array-size.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Fri Aug 10 18:33:42 2007
@@ -55,4 +55,5 @@
:make-f-array
:f-array-elt
- :f-array-replace))
+ :f-array-replace
+ :f-array-size))
From abaine at common-lisp.net Sat Aug 11 00:12:23 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 10 Aug 2007 20:12:23 -0400 (EDT)
Subject: [funds-cvs] r134 - trunk/funds/src/examples
Message-ID: <20070811001223.9B052340A1@common-lisp.net>
Author: abaine
Date: Fri Aug 10 20:12:23 2007
New Revision: 134
Added:
trunk/funds/src/examples/
trunk/funds/src/examples/sudoku.lisp
Log:
Added sudoku example file.
Added: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/sudoku.lisp Fri Aug 10 20:12:23 2007
@@ -0,0 +1,16 @@
+
+(in-package :funds)
+
+(defun puzzle-from-list (list-rep)
+ (let ((size (length list-rep)))
+ (make-f-array (expt size 3)
+ :initial-contents (mapcan #'(lambda (row)
+ (mapcan #'(lambda (elt)
+ (loop for i below size
+ collect (= i (1- elt))))
+ row))
+ list-rep))))
+
+
+
+
From abaine at common-lisp.net Tue Aug 14 04:48:37 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 14 Aug 2007 00:48:37 -0400 (EDT)
Subject: [funds-cvs] r135 - trunk/funds/src/examples
Message-ID: <20070814044837.C564C340A1@common-lisp.net>
Author: abaine
Date: Tue Aug 14 00:48:37 2007
New Revision: 135
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Start of a solver added.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Tue Aug 14 00:48:37 2007
@@ -1,16 +1,144 @@
(in-package :funds)
+(defconstant +false+ 0)
+(defconstant +true+ 1)
+(defconstant +unknown+ 2)
+
+(defun true-p (n) (= n +true+))
+(defun false-p (n) (= n +false+))
+(defun unknown-p (n) (= n +unknown+))
+(defun solved-p (n) (not (unknown-p n)))
+
+(defun range (size)
+ (case size
+ (0 '())
+ (1 '(1))
+ (4 '(0 1 2 3))
+ (9 '(0 1 2 3 4 5 6 7 8))
+ (25 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24))
+ (otherwise (loop for i below size collecting i))))
+
+(defstruct puzzle
+ size
+ tree)
+
(defun puzzle-from-list (list-rep)
(let ((size (length list-rep)))
- (make-f-array (expt size 3)
- :initial-contents (mapcan #'(lambda (row)
- (mapcan #'(lambda (elt)
- (loop for i below size
- collect (= i (1- elt))))
- row))
- list-rep))))
-
-
-
-
+ (make-puzzle
+ :size size
+ :tree
+ (make-f-array (expt size 3)
+ :initial-contents
+ (mapcan #'(lambda (row)
+ (mapcan #'(lambda (elt)
+ (loop for i below size
+ collect (cond ((zerop elt) +unknown+)
+ ((= i (1- elt)) +true+)
+ (t +false+))))
+ row))
+ list-rep)))))
+
+(defun list-from-puzzle (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (loop for i below size collect
+ (loop for j below size collect
+ (loop for k below size
+ when (true-p (puzzle-elt puzzle i j k))
+ do (return (1+ k))
+ finally (return 0))))))
+
+(defun puzzle-elt (puzzle row column number)
+ (f-array-elt (puzzle-tree puzzle)
+ (index-from-coordinates row column number (puzzle-size puzzle))))
+
+(defun puzzle-complete (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (loop for i below size always
+ (loop for j below size always
+ (loop for k below size always
+ (not (unknown-p (puzzle-elt puzzle i j k))))))))
+
+(defun set-to-true (puzzle i j k)
+ (fill-falses (make-puzzle :size (puzzle-size puzzle)
+ :tree (tree-insert (puzzle-tree puzzle)
+ (index-from-coordinates
+ i j k
+ (puzzle-size puzzle))
+ +true+))
+ i j k))
+
+(defun set-to-false (puzzle i j k)
+ (let ((size (puzzle-size puzzle)))
+ (make-puzzle :size size
+ :tree (tree-insert (puzzle-tree puzzle)
+ (index-from-coordinates i j k)
+ +false+))))
+
+(defun fill-falses (puzzle i j k)
+ (let ((size (puzzle-size puzzle)))
+ (make-puzzle :size size
+ :tree (reduce #'(lambda (tree index)
+ (reduce #'(lambda (tr x)
+ (if (unknown-p (tree-find tr x))
+ (tree-insert tr x +false+)
+ tr))
+ (list (index-from-coordinates i j index size)
+ (index-from-coordinates i index k size)
+ (index-from-coordinates index j k size)
+ (index-from-coordinates
+ (calc-i i j index size)
+ (calc-j i j index size)
+ k size))
+ :initial-value tree))
+ (range size)
+ :initial-value (puzzle-tree puzzle)))))
+
+(defun calc-i (i j index size)
+ (let ((order (order size)))
+ (+ (start i order)
+ (floor index order))))
+
+(defun calc-j (i j index size)
+ (let ((order (order size)))
+ (+ (start j order)
+ (mod index order))))
+
+
+(defun start (x order)
+ (* order (floor x order)))
+
+(defun order (size)
+ (round (sqrt size)))
+
+(defun index-from-coordinates (i j k size)
+ (+ (* i size size)
+ (* j size)
+ k))
+
+(defun complete-p (puzzle)
+ (labels ((f (tree)
+ (or (tree-empty-p tree)
+ (and (solved-p (bt-value tree))
+ (f (bt-left tree))
+ (f (bt-right tree))))))
+ (f (puzzle-tree puzzle))))
+
+(defun solvable-p (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (loop for i below size always
+ (loop for j below size always
+ (not (or (loop for k below size always (false-p (puzzle-elt puzzle i j k)))
+ (loop for k below size always (false-p (puzzle-elt puzzle i k j)))
+ (loop for k below size always (false-p (puzzle-elt puzzle k i j)))
+ (loop for k below size always
+ (false-p (puzzle-elt-by-box puzzle i j k)))))))))
+
+(defun puzzle-elt-by-box (puzzle number box index)
+ (let ((order (order (puzzle-size puzzle))))
+ (puzzle-elt puzzle
+ (+ (* order (floor box order))
+ (floor index order))
+ (+ (* order (mod box order))
+ (mod index order))
+ number)))
From abaine at common-lisp.net Thu Aug 16 03:28:16 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Wed, 15 Aug 2007 23:28:16 -0400 (EDT)
Subject: [funds-cvs] r136 - trunk/funds/src/examples
Message-ID: <20070816032816.AE4812E1B7@common-lisp.net>
Author: abaine
Date: Wed Aug 15 23:28:16 2007
New Revision: 136
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Closer to working solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Wed Aug 15 23:28:16 2007
@@ -104,7 +104,6 @@
(+ (start j order)
(mod index order))))
-
(defun start (x order)
(* order (floor x order)))
@@ -142,3 +141,70 @@
(+ (* order (mod box order))
(mod index order))
number)))
+
+(defun solve (puzzle)
+ (cond ((complete-p puzzle) puzzle)
+ ((not (solvable-p puzzle)) nil)
+ (t (multiple-value-bind (x y z) (most-constrained-coordinates puzzle)
+ (or (solve (set-to-true puzzle x y z))
+ (solve (set-to-false puzzle x y z)))))))
+
+(defun most-constrained-coordinates (puzzle)
+ (let* ((best-i -1)
+ (best-j -1)
+ (best-k -1)
+ (size (puzzle-size puzzle))
+ (best-n (1+ size)))
+ (loop for i below size do
+ when
+ finally (return (values best-i best-j best-k)))))
+
+
+
+(defun solve-row (puzzle j k)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (puzzle i)
+ (cond ((= i size) nil)
+ ((solved-p (puzzle-elt puzzle i j k) (f puzzle (1+ i))))
+ (t (or (solve (set-to-true puzzle i j k))
+ (f (set-to-false puzzle i j k) (1+ i)))))))
+ (f puzzle 0))))
+
+(defun solve-column (puzzle i k)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (puzzle j)
+ (cond ((= j size) nil)
+ ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ j)))
+ (t (or (solve (set-to-true puzzle i j k))
+ (f (set-to-false puzzle i j k) (1+ j)))))))
+ (f puzzle 0))))
+
+(defun solve-number (puzzle i j)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (puzzle k)
+ (cond ((= k size) nil)
+ ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ k))
+ (t (or (solve (set-to-true puzzle i j k))
+ (f (set-to-false puzzle i j k) (1+ k))))))))
+ (f puzzle 0))))
+
+(defun solve-box (puzzle box number)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (puzzle index)
+ (cond ((= index size)nil)
+ ((solved-p (puzzle-elt-by-box puzzle box number index)
+ (f (puzzle 1+ index)))
+ (t (or solve )))))
+))))
+
+
+
+
+(defun i-j-k-coordinates (i j k)
+ (values i j k))
+
+(defun j-k-i-coordinates (j k i)
+ (values i j k))
+
+(defun k-i-j-coordinates (k i j)
+ (values i j k))
\ No newline at end of file
From abaine at common-lisp.net Fri Aug 17 03:41:22 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Thu, 16 Aug 2007 23:41:22 -0400 (EDT)
Subject: [funds-cvs] r137 - in trunk/funds/src: . examples
Message-ID: <20070817034122.0138E431B7@common-lisp.net>
Author: abaine
Date: Thu Aug 16 23:41:22 2007
New Revision: 137
Added:
trunk/funds/src/examples/funds-examples.asd
trunk/funds/src/examples/package.lisp
Modified:
trunk/funds/src/examples/sudoku.lisp
trunk/funds/src/funds.asd
Log:
Improved example.
Added: trunk/funds/src/examples/funds-examples.asd
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/funds-examples.asd Thu Aug 16 23:41:22 2007
@@ -0,0 +1,15 @@
+
+;;;; -*- Lisp -*-
+
+(in-package :cl-user)
+
+(defpackage #:funds-examples-asd
+ (:use :cl :asdf))
+
+(in-package :funds-examples-asd)
+
+(defsystem funds-examples
+ :serial t
+ :components ((:file "package")
+ (:file "sudoku"))
+ :depends-on (:iterate :funds))
Added: trunk/funds/src/examples/package.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/package.lisp Thu Aug 16 23:41:22 2007
@@ -0,0 +1,5 @@
+
+(in-package :cl-user)
+
+(defpackage :funds-examples
+ (:use :funds :iterate))
\ No newline at end of file
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Thu Aug 16 23:41:22 2007
@@ -145,66 +145,58 @@
(defun solve (puzzle)
(cond ((complete-p puzzle) puzzle)
((not (solvable-p puzzle)) nil)
- (t (multiple-value-bind (x y z) (most-constrained-coordinates puzzle)
- (or (solve (set-to-true puzzle x y z))
- (solve (set-to-false puzzle x y z)))))))
+ (t (multiple-value-call #'solve-by-group
+ puzzle (most-constrained-group)))))
(defun most-constrained-coordinates (puzzle)
- (let* ((best-i -1)
- (best-j -1)
- (best-k -1)
- (size (puzzle-size puzzle))
- (best-n (1+ size)))
- (loop for i below size do
- when
- finally (return (values best-i best-j best-k)))))
-
-
-
-(defun solve-row (puzzle j k)
- (let ((size (puzzle-size puzzle)))
- (labels ((f (puzzle i)
- (cond ((= i size) nil)
- ((solved-p (puzzle-elt puzzle i j k) (f puzzle (1+ i))))
- (t (or (solve (set-to-true puzzle i j k))
- (f (set-to-false puzzle i j k) (1+ i)))))))
- (f puzzle 0))))
-
-(defun solve-column (puzzle i k)
- (let ((size (puzzle-size puzzle)))
- (labels ((f (puzzle j)
- (cond ((= j size) nil)
- ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ j)))
- (t (or (solve (set-to-true puzzle i j k))
- (f (set-to-false puzzle i j k) (1+ j)))))))
- (f puzzle 0))))
-
-(defun solve-number (puzzle i j)
- (let ((size (puzzle-size puzzle)))
- (labels ((f (puzzle k)
- (cond ((= k size) nil)
- ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ k))
- (t (or (solve (set-to-true puzzle i j k))
- (f (set-to-false puzzle i j k) (1+ k))))))))
- (f puzzle 0))))
-
-(defun solve-box (puzzle box number)
- (let ((size (puzzle-size puzzle)))
- (labels ((f (puzzle index)
- (cond ((= index size)nil)
- ((solved-p (puzzle-elt-by-box puzzle box number index)
- (f (puzzle 1+ index)))
- (t (or solve )))))
-))))
-
-
+ (let ((best-c #'i-j-k-coordinates)
+ (best-x -1)
+ (best-y -1)
+ (size (puzzle-size puzzle))
+ (least-n nil))
+ (loop :for x :below size :do
+ (loop :for y :below size :do
+ (loop :for c-function :in '(#'i-j-k-coordinates
+ #'j-k-i-coordinates
+ #'k-i-j-coordinates
+ #'b-n-i-coordinates)
+ :do (let ((n (loop :for z :below size :count
+ (unknown-p (multiple-value-call
+ #'puzzle-elt
+ (c-function x y z size))))))
+ (if (< n least-n)
+ (setf best-c c-function
+ best-x x
+ best-y y))))))
+ (values best-c best-x best-y)))
+
+(defun solve-by-group (puzzle c-function x y)
+ (let ((size (pussle-size puzzle)))
+ (labels ((f (puzzle z)
+ (if (= index size)
+ nil
+ (multiple-value-bind (i j k) (funcall c-function x y z size)
+ (if (solved-p (puzzle-elt puzzle i j k))
+ (f puzzle (1+ z))
+ (or (solve (set-to-true puzzle x y z))
+ (f (set-to-false puzzle i j k) (1+ z)))))))))))
+(defun i-j-k-coordinates (i j k size)
+ (declare (ignore size))
+ (values i j k))
-(defun i-j-k-coordinates (i j k)
+(defun j-k-i-coordinates (j k i size)
+ (declare (ignore size))
(values i j k))
-(defun j-k-i-coordinates (j k i)
+(defun k-i-j-coordinates (k i j size)
+ (declare (ignore size))
(values i j k))
-(defun k-i-j-coordinates (k i j)
- (values i j k))
\ No newline at end of file
+(defun b-n-i-coordinates (box number index size)
+ (let ((order (order size)))
+ (values (+ (* order (floor box order))
+ (floor index order))
+ (+ (* order (mod box order))
+ (mod index order))
+ number)))
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Thu Aug 16 23:41:22 2007
@@ -51,4 +51,3 @@
(:file "f-array")
(:file "dictionary")
(:file "queue")))
-
From abaine at common-lisp.net Sat Aug 18 03:08:21 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Fri, 17 Aug 2007 23:08:21 -0400 (EDT)
Subject: [funds-cvs] r138 - trunk/funds/src/examples
Message-ID: <20070818030821.C17071D200@common-lisp.net>
Author: abaine
Date: Fri Aug 17 23:08:21 2007
New Revision: 138
Modified:
trunk/funds/src/examples/package.lisp
trunk/funds/src/examples/sudoku.lisp
Log:
Improved example.
Modified: trunk/funds/src/examples/package.lisp
==============================================================================
--- trunk/funds/src/examples/package.lisp (original)
+++ trunk/funds/src/examples/package.lisp Fri Aug 17 23:08:21 2007
@@ -2,4 +2,4 @@
(in-package :cl-user)
(defpackage :funds-examples
- (:use :funds :iterate))
\ No newline at end of file
+ (:use :cl :funds :iterate))
\ No newline at end of file
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Fri Aug 17 23:08:21 2007
@@ -1,202 +1,139 @@
-(in-package :funds)
+(in-package :funds-examples)
(defconstant +false+ 0)
(defconstant +true+ 1)
-(defconstant +unknown+ 2)
-
-(defun true-p (n) (= n +true+))
-(defun false-p (n) (= n +false+))
-(defun unknown-p (n) (= n +unknown+))
-(defun solved-p (n) (not (unknown-p n)))
-
-(defun range (size)
- (case size
- (0 '())
- (1 '(1))
- (4 '(0 1 2 3))
- (9 '(0 1 2 3 4 5 6 7 8))
- (25 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24))
- (otherwise (loop for i below size collecting i))))
(defstruct puzzle
- size
+ size
tree)
+(defun puzzle-find (puzzle i j k)
+ (multiple-value-bind (v found)
+ (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle)))
+ (values v found)))
+
+(defun puzzle-elt-solved (puzzle i j k)
+ (multiple-value-bind (v found)
+ (puzzle-find puzzle i j k)
+ found))
+
+(defun puzzle-elt (puzzle i j k)
+ (puzzle-find puzzle i j k))
+
+(defun elt-true-p (elt)
+ (and elt (= elt +true+)))
+
+(defun elt-false-p (elt)
+ (and elt (= elt +false+)))
+
(defun puzzle-from-list (list-rep)
- (let ((size (length list-rep)))
- (make-puzzle
- :size size
- :tree
- (make-f-array (expt size 3)
- :initial-contents
- (mapcan #'(lambda (row)
- (mapcan #'(lambda (elt)
- (loop for i below size
- collect (cond ((zerop elt) +unknown+)
- ((= i (1- elt)) +true+)
- (t +false+))))
- row))
- list-rep)))))
+ (labels ((f (puzzle list row i j)
+ (cond ((null list) puzzle)
+ ((null row) (f puzzle (rest list) (first (rest list)) (1+ i) 0))
+ (t (f (if (zerop (first row))
+ puzzle
+ (fill-true puzzle i j (1- (first row))))
+ list (rest row) i (1+ j))))))
+ (f (make-puzzle :size (length list-rep)
+ :tree (make-avl-tree))
+ list-rep (first list-rep) 0 0)))
(defun list-from-puzzle (puzzle)
(let ((size (puzzle-size puzzle)))
- (loop for i below size collect
- (loop for j below size collect
- (loop for k below size
- when (true-p (puzzle-elt puzzle i j k))
- do (return (1+ k))
- finally (return 0))))))
-
-(defun puzzle-elt (puzzle row column number)
- (f-array-elt (puzzle-tree puzzle)
- (index-from-coordinates row column number (puzzle-size puzzle))))
+ (iter (for i below size)
+ (collect (iter (for j below size)
+ (collect (iter (for k below size)
+ (when (elt-true-p (puzzle-elt puzzle i j k))
+ (return (1+ k)))
+ (finally (return 0)))))))))
-(defun puzzle-complete (puzzle)
- (let ((size (puzzle-size puzzle)))
- (loop for i below size always
- (loop for j below size always
- (loop for k below size always
- (not (unknown-p (puzzle-elt puzzle i j k))))))))
+(defun fill-true (puzzle i j k)
+ (fill-falses (set-to-true puzzle i j k) i j k))
-(defun set-to-true (puzzle i j k)
- (fill-falses (make-puzzle :size (puzzle-size puzzle)
- :tree (tree-insert (puzzle-tree puzzle)
- (index-from-coordinates
- i j k
- (puzzle-size puzzle))
- +true+))
- i j k))
+(defun fill-falses (puzzle i j k)
+ (fill-falses-row
+ (fill-falses-column
+ (fill-falses-number
+ (fill-falses-box puzzle i j k)
+ i j k)
+ i j k)
+ i j k))
-(defun set-to-false (puzzle i j k)
- (let ((size (puzzle-size puzzle)))
- (make-puzzle :size size
- :tree (tree-insert (puzzle-tree puzzle)
- (index-from-coordinates i j k)
- +false+))))
-(defun fill-falses (puzzle i j k)
+
+(defun fill-falses-row (puzzle i j k)
+ (fill-falses-group puzzle #'row-coordinates i j k) )
+
+(defun fill-falses-column (puzzle i j k)
+ (fill-falses-group puzzle #'column-coordinates i j k))
+
+(defun fill-falses-number (puzzle i j k)
+ (fill-falses-group puzzle #'number-coordinates i j k))
+
+(defun fill-falses-box (puzzle i j k)
+ (fill-falses-group puzzle #'box-coordinates i j k))
+
+(defun fill-falses-group (puzzle c-function i j k)
(let ((size (puzzle-size puzzle)))
- (make-puzzle :size size
- :tree (reduce #'(lambda (tree index)
- (reduce #'(lambda (tr x)
- (if (unknown-p (tree-find tr x))
- (tree-insert tr x +false+)
- tr))
- (list (index-from-coordinates i j index size)
- (index-from-coordinates i index k size)
- (index-from-coordinates index j k size)
- (index-from-coordinates
- (calc-i i j index size)
- (calc-j i j index size)
- k size))
- :initial-value tree))
- (range size)
- :initial-value (puzzle-tree puzzle)))))
-
-(defun calc-i (i j index size)
- (let ((order (order size)))
- (+ (start i order)
- (floor index order))))
-
-(defun calc-j (i j index size)
- (let ((order (order size)))
- (+ (start j order)
- (mod index order))))
+ (labels ((f (puzzle x)
+ (if (= x size)
+ puzzle
+ (f (multiple-value-call #'set-to-false
+ puzzle (funcall c-function i j k x size))
+ (1+ x)))))
+ (f puzzle 0))))
+
+(defun box-coordinates (i j k x size)
+(let ((order (order size)))
+ (values (+ (* order (floor i order))
+ (floor x order))
+ (+ (* order (floor j order))
+ (mod x order))
+ k)))
+
+
+(defun row-coordinates (i j k x size)
+ (declare (ignore i size))
+ (values x j k))
+
+(defun column-coordinates (i j k x size)
+ (declare (ignore j size))
+ (values i x k))
+
+(defun number-coordinates (i j k x size)
+ (declare (ignore k size))
+ (values i j x))
-(defun start (x order)
- (* order (floor x order)))
+(defun set-to-true (puzzle i j k)
+ (set-value puzzle i j k +true+))
+(defun set-to-false (puzzle i j k)
+ (set-value puzzle i j k +false+))
+
+(defun set-value (puzzle i j k value)
+ (if (puzzle-elt puzzle i j k)
+ puzzle
+ (let ((size (puzzle-size puzzle)))
+ (make-puzzle :size size
+ :tree (tree-insert (puzzle-tree puzzle)
+ (index i j k size)
+ value)))))
(defun order (size)
(round (sqrt size)))
-(defun index-from-coordinates (i j k size)
+(defun index (i j k size)
(+ (* i size size)
(* j size)
k))
-(defun complete-p (puzzle)
- (labels ((f (tree)
- (or (tree-empty-p tree)
- (and (solved-p (bt-value tree))
- (f (bt-left tree))
- (f (bt-right tree))))))
- (f (puzzle-tree puzzle))))
-
-(defun solvable-p (puzzle)
+(defun debug-print (puzzle)
(let ((size (puzzle-size puzzle)))
- (loop for i below size always
- (loop for j below size always
- (not (or (loop for k below size always (false-p (puzzle-elt puzzle i j k)))
- (loop for k below size always (false-p (puzzle-elt puzzle i k j)))
- (loop for k below size always (false-p (puzzle-elt puzzle k i j)))
- (loop for k below size always
- (false-p (puzzle-elt-by-box puzzle i j k)))))))))
-
-(defun puzzle-elt-by-box (puzzle number box index)
- (let ((order (order (puzzle-size puzzle))))
- (puzzle-elt puzzle
- (+ (* order (floor box order))
- (floor index order))
- (+ (* order (mod box order))
- (mod index order))
- number)))
-
-(defun solve (puzzle)
- (cond ((complete-p puzzle) puzzle)
- ((not (solvable-p puzzle)) nil)
- (t (multiple-value-call #'solve-by-group
- puzzle (most-constrained-group)))))
-
-(defun most-constrained-coordinates (puzzle)
- (let ((best-c #'i-j-k-coordinates)
- (best-x -1)
- (best-y -1)
- (size (puzzle-size puzzle))
- (least-n nil))
- (loop :for x :below size :do
- (loop :for y :below size :do
- (loop :for c-function :in '(#'i-j-k-coordinates
- #'j-k-i-coordinates
- #'k-i-j-coordinates
- #'b-n-i-coordinates)
- :do (let ((n (loop :for z :below size :count
- (unknown-p (multiple-value-call
- #'puzzle-elt
- (c-function x y z size))))))
- (if (< n least-n)
- (setf best-c c-function
- best-x x
- best-y y))))))
- (values best-c best-x best-y)))
-
-(defun solve-by-group (puzzle c-function x y)
- (let ((size (pussle-size puzzle)))
- (labels ((f (puzzle z)
- (if (= index size)
- nil
- (multiple-value-bind (i j k) (funcall c-function x y z size)
- (if (solved-p (puzzle-elt puzzle i j k))
- (f puzzle (1+ z))
- (or (solve (set-to-true puzzle x y z))
- (f (set-to-false puzzle i j k) (1+ z)))))))))))
-
-(defun i-j-k-coordinates (i j k size)
- (declare (ignore size))
- (values i j k))
-
-(defun j-k-i-coordinates (j k i size)
- (declare (ignore size))
- (values i j k))
-
-(defun k-i-j-coordinates (k i j size)
- (declare (ignore size))
- (values i j k))
-
-(defun b-n-i-coordinates (box number index size)
- (let ((order (order size)))
- (values (+ (* order (floor box order))
- (floor index order))
- (+ (* order (mod box order))
- (mod index order))
- number)))
+ (iter (for k below size)
+ (format t "~%~%~{~&~{~2A~}~}"
+ (iter (for i below size)
+ (collect (iter (for j below size)
+ (collect (or (puzzle-elt puzzle i j k)
+ "")))))))))
+
+
From abaine at common-lisp.net Sat Aug 18 05:45:37 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 01:45:37 -0400 (EDT)
Subject: [funds-cvs] r139 - trunk/funds/src/examples
Message-ID: <20070818054537.25D5B13029@common-lisp.net>
Author: abaine
Date: Sat Aug 18 01:45:36 2007
New Revision: 139
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Continued improving example.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 01:45:36 2007
@@ -27,6 +27,9 @@
(defun elt-false-p (elt)
(and elt (= elt +false+)))
+(defun elt-unknown-p (elt)
+ (null elt))
+
(defun puzzle-from-list (list-rep)
(labels ((f (puzzle list row i j)
(cond ((null list) puzzle)
@@ -136,4 +139,83 @@
(collect (or (puzzle-elt puzzle i j k)
"")))))))))
+(defun best-solver (puzzle)
+ (iter (for f in (list #'best-row
+ #'best-column
+ #'best-number
+ #'best-box))
+ (for s in (list #'solve-row
+ #'solve-column
+ #'solve-number
+ #'solve-box))
+ (for (values x y n) = (funcall f puzzle))
+ (finding x minimizing n into best-x)
+ (finding y minimizing n into best-y)
+ (finding s minimizing n into (best-s min))
+ (when (= min 1)
+ (return (funcall best-s puzzle best-x best-y)))
+ (finally (return (funcall best-s puzzle best-x best-y)))))
+
+(defun best-row (puzzle)
+ (best-group puzzle #'row-freedom))
+
+(defun best-column (puzzle)
+ (best-group puzzle #'column-freedom))
+
+(defun best-number (puzzle)
+ (best-group puzzle #'number-freedom))
+
+(defun best-box (puzzle)
+ (best-group puzzle #'box-freedom))
+
+(defun best-group (puzzle freedom-function)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for x below size)
+ (for (values y n) =
+ (iter (for y below size)
+ (for n = (funcall freedom-function puzzle x y))
+ (finding y minimizing n into (best-y min))
+ (when (= min 1)
+ (return (values best-y min)))
+ (finally (return (values best-y min)))))
+ (finding x minimizing n into best-x)
+ (finding y minimizing n into (best-y best-n))
+ (when (= best-n 1)
+ (return (values best-x best-y best-n)))
+ (finally (return (values best-x best-y best-n))))))
+
+(defun row-freedom (puzzle i k)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for j below size)
+ (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
+ (finally (return (enlarge-zero c size) )))))
+
+(defun column-freedom (puzzle j k)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for i below size)
+ (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
+ (finally (return (enlarge-zero c size))))))
+
+(defun number-freedom (puzzle i j)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for k below size)
+ (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
+ (finally (return (enlarge-zero c size))))))
+(defun box-freedom (puzzle b k)
+ (let* ((size (puzzle-size puzzle))
+ (order (order size)))
+ (iter (for x below size)
+ (counting (elt-unknown-p (puzzle-elt puzzle
+ (+ (* order (floor b order))
+ (floor x order))
+ (+ (* order (mod b order))
+ (mod x order))
+ k))
+ into c)
+ (finally (return (enlarge-zero c size))))))
+
+(defun enlarge-zero (count size)
+ (if (zerop count)
+ (1+ size)
+ count))
From abaine at common-lisp.net Sat Aug 18 20:45:39 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 16:45:39 -0400 (EDT)
Subject: [funds-cvs] r140 - trunk/funds/src/examples
Message-ID: <20070818204539.57ECA3C088@common-lisp.net>
Author: abaine
Date: Sat Aug 18 16:45:39 2007
New Revision: 140
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Working solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 16:45:39 2007
@@ -24,9 +24,6 @@
(defun elt-true-p (elt)
(and elt (= elt +true+)))
-(defun elt-false-p (elt)
- (and elt (= elt +false+)))
-
(defun elt-unknown-p (elt)
(null elt))
@@ -139,7 +136,7 @@
(collect (or (puzzle-elt puzzle i j k)
"")))))))))
-(defun best-solver (puzzle)
+(defun solve (puzzle)
(iter (for f in (list #'best-row
#'best-column
#'best-number
@@ -190,18 +187,26 @@
(counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
(finally (return (enlarge-zero c size) )))))
+
+
+
(defun column-freedom (puzzle j k)
(let ((size (puzzle-size puzzle)))
(iter (for i below size)
(counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
(finally (return (enlarge-zero c size))))))
+
+
(defun number-freedom (puzzle i j)
(let ((size (puzzle-size puzzle)))
(iter (for k below size)
(counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
(finally (return (enlarge-zero c size))))))
+
+
+
(defun box-freedom (puzzle b k)
(let* ((size (puzzle-size puzzle))
(order (order size)))
@@ -219,3 +224,56 @@
(if (zerop count)
(1+ size)
count))
+
+(defun solve-row (puzzle i k)
+ (solve-group puzzle #'i-k-j-coordinates i k))
+
+(defun solve-column (puzzle j k)
+ (solve-group puzzle #'j-k-i-coordinates j k))
+
+(defun solve-number (puzzle i j)
+ (solve-group puzzle #'i-j-k-coordinates i j))
+
+(defun solve-box (puzzle b k)
+ (solve-group puzzle #'b-k-x-coordinates b k))
+
+(defun solve-group (puzzle c-function x y)
+ (if (complete-p puzzle)
+ puzzle
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (z)
+ (if (= z size) nil
+ (multiple-value-bind (i j k)
+ (funcall c-function x y z puzzle)
+ (if (puzzle-elt-solved puzzle i j k)
+ (f (1+ z))
+ (or (solve (multiple-value-call
+ #'fill-true puzzle
+ (funcall c-function x y z puzzle)))
+ (f (1+ z))))))))
+
+ (f 0)))))
+
+(defun complete-p (puzzle)
+ (= (tree-weight (puzzle-tree puzzle))
+ (round (expt (puzzle-size puzzle) 3))))
+
+(defun i-j-k-coordinates (i j k puzzle)
+ (declare (ignore puzzle))
+ (values i j k))
+
+(defun i-k-j-coordinates (i k j puzzle)
+ (declare (ignore puzzle))
+ (values i j k))
+
+(defun j-k-i-coordinates (j k i puzzle)
+ (declare (ignore puzzle))
+ (values i j k))
+
+(defun b-k-x-coordinates (b k x puzzle)
+ (let ((order (order (puzzle-size puzzle))))
+ (values (+ (* order (floor b order))
+ (floor x order))
+ (+ (* order (mod b order))
+ (mod x order))
+ k)))
\ No newline at end of file
From abaine at common-lisp.net Sat Aug 18 22:56:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 18:56:29 -0400 (EDT)
Subject: [funds-cvs] r141 - trunk/funds/src/examples
Message-ID: <20070818225629.E130B65128@common-lisp.net>
Author: abaine
Date: Sat Aug 18 18:56:29 2007
New Revision: 141
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Minor changes to solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 18:56:29 2007
@@ -60,8 +60,6 @@
i j k)
i j k))
-
-
(defun fill-falses-row (puzzle i j k)
(fill-falses-group puzzle #'row-coordinates i j k) )
@@ -137,21 +135,25 @@
"")))))))))
(defun solve (puzzle)
- (iter (for f in (list #'best-row
- #'best-column
- #'best-number
- #'best-box))
- (for s in (list #'solve-row
- #'solve-column
- #'solve-number
- #'solve-box))
- (for (values x y n) = (funcall f puzzle))
- (finding x minimizing n into best-x)
- (finding y minimizing n into best-y)
- (finding s minimizing n into (best-s min))
- (when (= min 1)
- (return (funcall best-s puzzle best-x best-y)))
- (finally (return (funcall best-s puzzle best-x best-y)))))
+ (if (complete-p puzzle)
+ (if (solved-p puzzle)
+ puzzle
+ nil)
+ (iter (for f in (list #'best-row
+ #'best-column
+ #'best-number
+ #'best-box))
+ (for s in (list #'solve-row
+ #'solve-column
+ #'solve-number
+ #'solve-box))
+ (for (values x y n) = (funcall f puzzle))
+ (finding x minimizing n into best-x)
+ (finding y minimizing n into best-y)
+ (finding s minimizing n into (best-s min))
+ (when (= min 1)
+ (return (funcall best-s puzzle best-x best-y)))
+ (finally (return (funcall best-s puzzle best-x best-y))))))
(defun best-row (puzzle)
(best-group puzzle #'row-freedom))
@@ -204,9 +206,6 @@
(counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
(finally (return (enlarge-zero c size))))))
-
-
-
(defun box-freedom (puzzle b k)
(let* ((size (puzzle-size puzzle))
(order (order size)))
@@ -220,6 +219,12 @@
into c)
(finally (return (enlarge-zero c size))))))
+(defun group-freedom (puzzle x-y-z-function x y)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for z below size)
+ (counting (elt-unknown-p (multiple-value-call #'puzzle-elt puzzle
+ (funcall x-y-z-function x y z size)))))))
+
(defun enlarge-zero (count size)
(if (zerop count)
(1+ size)
@@ -237,43 +242,58 @@
(defun solve-box (puzzle b k)
(solve-group puzzle #'b-k-x-coordinates b k))
-(defun solve-group (puzzle c-function x y)
- (if (complete-p puzzle)
- puzzle
- (let ((size (puzzle-size puzzle)))
- (labels ((f (z)
- (if (= z size) nil
- (multiple-value-bind (i j k)
- (funcall c-function x y z puzzle)
- (if (puzzle-elt-solved puzzle i j k)
- (f (1+ z))
- (or (solve (multiple-value-call
- #'fill-true puzzle
- (funcall c-function x y z puzzle)))
- (f (1+ z))))))))
+(defun solve-group (puzzle x-y-z-function x y)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (z)
+ (if (= z size) nil
+ (multiple-value-bind (i j k)
+ (funcall x-y-z-function x y z size)
+ (if (puzzle-elt-solved puzzle i j k)
+ (f (1+ z))
+ (or (solve (fill-true puzzle i j k))
+ (f (1+ z))))))))
- (f 0)))))
+ (f 0))))
(defun complete-p (puzzle)
(= (tree-weight (puzzle-tree puzzle))
(round (expt (puzzle-size puzzle) 3))))
-(defun i-j-k-coordinates (i j k puzzle)
- (declare (ignore puzzle))
+(defun solved-p (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for x below size)
+ (always (iter (for y below size)
+ (always (iter (for x-y-z-function in (list
+ #'i-j-k-coordinates
+ #'i-k-j-coordinates
+ #'j-k-i-coordinates
+ #'b-k-x-coordinates))
+ (always (group-solved puzzle x-y-z-function x y)))))))))
+
+(defun i-j-k-coordinates (i j k size)
+ (declare (ignore size))
(values i j k))
-(defun i-k-j-coordinates (i k j puzzle)
- (declare (ignore puzzle))
+(defun i-k-j-coordinates (i k j size)
+ (declare (ignore size))
(values i j k))
-(defun j-k-i-coordinates (j k i puzzle)
- (declare (ignore puzzle))
+(defun j-k-i-coordinates (j k i size)
+ (declare (ignore size))
(values i j k))
-(defun b-k-x-coordinates (b k x puzzle)
- (let ((order (order (puzzle-size puzzle))))
+(defun b-k-x-coordinates (b k x size)
+ (let ((order (order size)))
(values (+ (* order (floor b order))
(floor x order))
(+ (* order (mod b order))
(mod x order))
- k)))
\ No newline at end of file
+ k)))
+
+(defun group-solved (puzzle x-y-z-function x y)
+ (let ((size (puzzle-size puzzle)))
+ (= 1 (iter (for z below size)
+ (count (elt-true-p (multiple-value-call
+ #'puzzle-elt puzzle
+ (funcall x-y-z-function x y z size))))))))
+
From abaine at common-lisp.net Sat Aug 18 23:15:57 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 19:15:57 -0400 (EDT)
Subject: [funds-cvs] r142 - trunk/funds/src/examples
Message-ID: <20070818231557.F37CF3C089@common-lisp.net>
Author: abaine
Date: Sat Aug 18 19:15:57 2007
New Revision: 142
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Box-number.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 19:15:57 2007
@@ -82,6 +82,21 @@
(1+ x)))))
(f puzzle 0))))
+(defun box-number (puzzle i j)
+ (let ((order (order (puzzle-size puzzle))))
+ (+ (* order (floor i order))
+ (floor j order))))
+
+(defun fill-falses-group-2 (puzzle x-y-z-function x y)
+ (let ((size (puzzle-size puzzle)))
+ (labels ((f (puzzle z)
+ (if (= z size)
+ puzzle
+ (f (multiple-value-call #'set-to-false
+ puzzle (funcall x-y-z-function x y z size))
+ (1+ z)))))
+ (f puzzle 0))))
+
(defun box-coordinates (i j k x size)
(let ((order (order size)))
(values (+ (* order (floor i order))
@@ -296,4 +311,3 @@
(count (elt-true-p (multiple-value-call
#'puzzle-elt puzzle
(funcall x-y-z-function x y z size))))))))
-
From abaine at common-lisp.net Sat Aug 18 23:43:07 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 19:43:07 -0400 (EDT)
Subject: [funds-cvs] r143 - trunk/funds/src/examples
Message-ID: <20070818234307.1A37843214@common-lisp.net>
Author: abaine
Date: Sat Aug 18 19:43:06 2007
New Revision: 143
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Improved solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 19:43:06 2007
@@ -52,25 +52,14 @@
(fill-falses (set-to-true puzzle i j k) i j k))
(defun fill-falses (puzzle i j k)
- (fill-falses-row
- (fill-falses-column
- (fill-falses-number
- (fill-falses-box puzzle i j k)
- i j k)
- i j k)
- i j k))
-
-(defun fill-falses-row (puzzle i j k)
- (fill-falses-group puzzle #'row-coordinates i j k) )
-
-(defun fill-falses-column (puzzle i j k)
- (fill-falses-group puzzle #'column-coordinates i j k))
-
-(defun fill-falses-number (puzzle i j k)
- (fill-falses-group puzzle #'number-coordinates i j k))
-
-(defun fill-falses-box (puzzle i j k)
- (fill-falses-group puzzle #'box-coordinates i j k))
+ (let ((b (box-number puzzle i j)))
+ (reduce #'(lambda (p group)
+ (apply #'fill-falses-group-2 p group))
+ (list (list #'i-j-k-coordinates i j)
+ (list #'j-k-i-coordinates j k)
+ (list #'i-k-j-coordinates i k)
+ (list #'b-k-x-coordinates b k))
+ :initial-value puzzle)))
(defun fill-falses-group (puzzle c-function i j k)
(let ((size (puzzle-size puzzle)))
@@ -97,27 +86,6 @@
(1+ z)))))
(f puzzle 0))))
-(defun box-coordinates (i j k x size)
-(let ((order (order size)))
- (values (+ (* order (floor i order))
- (floor x order))
- (+ (* order (floor j order))
- (mod x order))
- k)))
-
-
-(defun row-coordinates (i j k x size)
- (declare (ignore i size))
- (values x j k))
-
-(defun column-coordinates (i j k x size)
- (declare (ignore j size))
- (values i x k))
-
-(defun number-coordinates (i j k x size)
- (declare (ignore k size))
- (values i j x))
-
(defun set-to-true (puzzle i j k)
(set-value puzzle i j k +true+))
From abaine at common-lisp.net Sun Aug 19 00:19:02 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 20:19:02 -0400 (EDT)
Subject: [funds-cvs] r144 - trunk/funds/src/examples
Message-ID: <20070819001902.8EFAC49053@common-lisp.net>
Author: abaine
Date: Sat Aug 18 20:19:01 2007
New Revision: 144
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Solver's getting good.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 20:19:01 2007
@@ -122,40 +122,19 @@
(if (solved-p puzzle)
puzzle
nil)
- (iter (for f in (list #'best-row
- #'best-column
- #'best-number
- #'best-box))
- (for s in (list #'solve-row
- #'solve-column
- #'solve-number
- #'solve-box))
- (for (values x y n) = (funcall f puzzle))
- (finding x minimizing n into best-x)
- (finding y minimizing n into best-y)
- (finding s minimizing n into (best-s min))
- (when (= min 1)
- (return (funcall best-s puzzle best-x best-y)))
- (finally (return (funcall best-s puzzle best-x best-y))))))
-
-(defun best-row (puzzle)
- (best-group puzzle #'row-freedom))
-
-(defun best-column (puzzle)
- (best-group puzzle #'column-freedom))
+ (iter (for f in x-y-z-functions)
+ (for (values x y n) = (best-group puzzle f))
+ (finding (list f x y) minimizing n into (best-list min))
+ (when (= min 1)
+ (return (apply #'solve-group puzzle best-list)))
+ (finally (return (apply #'solve-group puzzle best-list))))))
-(defun best-number (puzzle)
- (best-group puzzle #'number-freedom))
-
-(defun best-box (puzzle)
- (best-group puzzle #'box-freedom))
-
-(defun best-group (puzzle freedom-function)
+(defun best-group (puzzle x-y-z-function)
(let ((size (puzzle-size puzzle)))
(iter (for x below size)
(for (values y n) =
(iter (for y below size)
- (for n = (funcall freedom-function puzzle x y))
+ (for n = (group-freedom puzzle x-y-z-function x y))
(finding y minimizing n into (best-y min))
(when (= min 1)
(return (values best-y min)))
@@ -166,65 +145,19 @@
(return (values best-x best-y best-n)))
(finally (return (values best-x best-y best-n))))))
-(defun row-freedom (puzzle i k)
- (let ((size (puzzle-size puzzle)))
- (iter (for j below size)
- (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
- (finally (return (enlarge-zero c size) )))))
-
-
-
-
-(defun column-freedom (puzzle j k)
- (let ((size (puzzle-size puzzle)))
- (iter (for i below size)
- (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
- (finally (return (enlarge-zero c size))))))
-
-
-
-(defun number-freedom (puzzle i j)
- (let ((size (puzzle-size puzzle)))
- (iter (for k below size)
- (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c)
- (finally (return (enlarge-zero c size))))))
-
-(defun box-freedom (puzzle b k)
- (let* ((size (puzzle-size puzzle))
- (order (order size)))
- (iter (for x below size)
- (counting (elt-unknown-p (puzzle-elt puzzle
- (+ (* order (floor b order))
- (floor x order))
- (+ (* order (mod b order))
- (mod x order))
- k))
- into c)
- (finally (return (enlarge-zero c size))))))
-
(defun group-freedom (puzzle x-y-z-function x y)
(let ((size (puzzle-size puzzle)))
- (iter (for z below size)
- (counting (elt-unknown-p (multiple-value-call #'puzzle-elt puzzle
- (funcall x-y-z-function x y z size)))))))
+ (enlarge-zero
+ (iter (for z below size)
+ (counting (elt-unknown-p (multiple-value-call #'puzzle-elt puzzle
+ (funcall x-y-z-function x y z size)))))
+ size)))
(defun enlarge-zero (count size)
(if (zerop count)
(1+ size)
count))
-(defun solve-row (puzzle i k)
- (solve-group puzzle #'i-k-j-coordinates i k))
-
-(defun solve-column (puzzle j k)
- (solve-group puzzle #'j-k-i-coordinates j k))
-
-(defun solve-number (puzzle i j)
- (solve-group puzzle #'i-j-k-coordinates i j))
-
-(defun solve-box (puzzle b k)
- (solve-group puzzle #'b-k-x-coordinates b k))
-
(defun solve-group (puzzle x-y-z-function x y)
(let ((size (puzzle-size puzzle)))
(labels ((f (z)
@@ -246,12 +179,8 @@
(let ((size (puzzle-size puzzle)))
(iter (for x below size)
(always (iter (for y below size)
- (always (iter (for x-y-z-function in (list
- #'i-j-k-coordinates
- #'i-k-j-coordinates
- #'j-k-i-coordinates
- #'b-k-x-coordinates))
- (always (group-solved puzzle x-y-z-function x y)))))))))
+ (always (iter (for f in x-y-z-functions)
+ (always (group-solved puzzle f x y)))))))))
(defun i-j-k-coordinates (i j k size)
(declare (ignore size))
@@ -279,3 +208,23 @@
(count (elt-true-p (multiple-value-call
#'puzzle-elt puzzle
(funcall x-y-z-function x y z size))))))))
+
+(defun puzzle-solvable (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for f in x-y-z-functions)
+ (always (iter (for x below size)
+ (always (iter (for y below size)
+ (always (group-solvable puzzle f x y)))))))))
+
+(defun group-solvable (puzzle x-y-z-function x y)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for z below size)
+ (for elt = (multiple-value-call #'puzzle-elt
+ puzzle (funcall x-y-z-function x y z size)))
+ (thereis (or (elt-unknown-p elt)
+ (elt-true-p elt))))))
+
+(defvar x-y-z-functions (list #'i-j-k-coordinates
+ #'i-k-j-coordinates
+ #'j-k-i-coordinates
+ #'b-k-x-coordinates))
From abaine at common-lisp.net Sun Aug 19 01:02:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sat, 18 Aug 2007 21:02:29 -0400 (EDT)
Subject: [funds-cvs] r145 - trunk/funds/src/examples
Message-ID: <20070819010229.55ACA6824D@common-lisp.net>
Author: abaine
Date: Sat Aug 18 21:02:29 2007
New Revision: 145
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Good solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 21:02:29 2007
@@ -8,18 +8,8 @@
size
tree)
-(defun puzzle-find (puzzle i j k)
- (multiple-value-bind (v found)
- (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle)))
- (values v found)))
-
-(defun puzzle-elt-solved (puzzle i j k)
- (multiple-value-bind (v found)
- (puzzle-find puzzle i j k)
- found))
-
(defun puzzle-elt (puzzle i j k)
- (puzzle-find puzzle i j k))
+ (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle))))
(defun elt-true-p (elt)
(and elt (= elt +true+)))
@@ -48,6 +38,24 @@
(return (1+ k)))
(finally (return 0)))))))))
+(defun puzzle-complete-p (puzzle)
+ (= (tree-weight (puzzle-tree puzzle))
+ (round (expt (puzzle-size puzzle) 3))))
+
+(defun puzzle-solved-p (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for x below size)
+ (always (iter (for y below size)
+ (always (iter (for f in x-y-z-functions)
+ (always (group-solved puzzle f x y)))))))))
+
+(defun puzzle-solvable-p (puzzle)
+ (let ((size (puzzle-size puzzle)))
+ (iter (for f in x-y-z-functions)
+ (always (iter (for x below size)
+ (always (iter (for y below size)
+ (always (group-solvable puzzle f x y)))))))))
+
(defun fill-true (puzzle i j k)
(fill-falses (set-to-true puzzle i j k) i j k))
@@ -118,16 +126,16 @@
"")))))))))
(defun solve (puzzle)
- (if (complete-p puzzle)
- (if (solved-p puzzle)
+ (if (puzzle-solvable-p puzzle)
+ (if (puzzle-complete-p puzzle)
puzzle
- nil)
- (iter (for f in x-y-z-functions)
- (for (values x y n) = (best-group puzzle f))
- (finding (list f x y) minimizing n into (best-list min))
- (when (= min 1)
- (return (apply #'solve-group puzzle best-list)))
- (finally (return (apply #'solve-group puzzle best-list))))))
+ (iter (for f in x-y-z-functions)
+ (for (values x y n) = (best-group puzzle f))
+ (finding (list f x y) minimizing n into (best-list min))
+ (when (= min 1)
+ (return (apply #'solve-group puzzle best-list)))
+ (finally (return (apply #'solve-group puzzle best-list)))))
+ nil))
(defun best-group (puzzle x-y-z-function)
(let ((size (puzzle-size puzzle)))
@@ -164,24 +172,12 @@
(if (= z size) nil
(multiple-value-bind (i j k)
(funcall x-y-z-function x y z size)
- (if (puzzle-elt-solved puzzle i j k)
+ (if (puzzle-elt puzzle i j k)
(f (1+ z))
(or (solve (fill-true puzzle i j k))
(f (1+ z))))))))
-
(f 0))))
-(defun complete-p (puzzle)
- (= (tree-weight (puzzle-tree puzzle))
- (round (expt (puzzle-size puzzle) 3))))
-
-(defun solved-p (puzzle)
- (let ((size (puzzle-size puzzle)))
- (iter (for x below size)
- (always (iter (for y below size)
- (always (iter (for f in x-y-z-functions)
- (always (group-solved puzzle f x y)))))))))
-
(defun i-j-k-coordinates (i j k size)
(declare (ignore size))
(values i j k))
@@ -209,13 +205,6 @@
#'puzzle-elt puzzle
(funcall x-y-z-function x y z size))))))))
-(defun puzzle-solvable (puzzle)
- (let ((size (puzzle-size puzzle)))
- (iter (for f in x-y-z-functions)
- (always (iter (for x below size)
- (always (iter (for y below size)
- (always (group-solvable puzzle f x y)))))))))
-
(defun group-solvable (puzzle x-y-z-function x y)
(let ((size (puzzle-size puzzle)))
(iter (for z below size)
From abaine at common-lisp.net Sun Aug 19 14:58:45 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 10:58:45 -0400 (EDT)
Subject: [funds-cvs] r146 - trunk/funds/src/examples
Message-ID: <20070819145845.D32596108F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 10:58:45 2007
New Revision: 146
Modified:
trunk/funds/src/examples/package.lisp
Log:
Exported solve from example.
Modified: trunk/funds/src/examples/package.lisp
==============================================================================
--- trunk/funds/src/examples/package.lisp (original)
+++ trunk/funds/src/examples/package.lisp Sun Aug 19 10:58:45 2007
@@ -2,4 +2,6 @@
(in-package :cl-user)
(defpackage :funds-examples
- (:use :cl :funds :iterate))
\ No newline at end of file
+ (:use :cl :funds :iterate)
+ (:export :solve
+ :p1 :p2))
\ No newline at end of file
From abaine at common-lisp.net Sun Aug 19 15:03:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:03:03 -0400 (EDT)
Subject: [funds-cvs] r147 - trunk/funds/src/examples
Message-ID: <20070819150303.CA97F2E1CF@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:03:03 2007
New Revision: 147
Modified:
trunk/funds/src/examples/funds-examples.asd
Log:
Added puzzles to defsystem.
Modified: trunk/funds/src/examples/funds-examples.asd
==============================================================================
--- trunk/funds/src/examples/funds-examples.asd (original)
+++ trunk/funds/src/examples/funds-examples.asd Sun Aug 19 11:03:03 2007
@@ -11,5 +11,6 @@
(defsystem funds-examples
:serial t
:components ((:file "package")
- (:file "sudoku"))
+ (:file "sudoku")
+ (:file "puzzles"))
:depends-on (:iterate :funds))
From abaine at common-lisp.net Sun Aug 19 15:03:31 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:03:31 -0400 (EDT)
Subject: [funds-cvs] r148 - trunk/funds/src/examples
Message-ID: <20070819150331.D89272E1CF@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:03:31 2007
New Revision: 148
Added:
trunk/funds/src/examples/puzzles.lisp
Log:
Added puzzles.
Added: trunk/funds/src/examples/puzzles.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/puzzles.lisp Sun Aug 19 11:03:31 2007
@@ -0,0 +1,22 @@
+
+(in-package :funds-examples)
+
+(defconstant p1 '((7 0 0 1 0 8 0 0 0)
+ (0 9 0 0 0 0 0 3 2)
+ (0 0 0 0 0 5 0 0 0)
+ (0 0 0 0 0 0 1 0 0)
+ (9 6 0 0 2 0 0 0 0)
+ (0 0 0 0 0 0 8 0 0)
+ (0 0 0 0 0 0 0 0 0)
+ (0 0 5 0 0 1 0 0 0)
+ (3 2 0 0 0 0 0 0 6)))
+
+(defconstant p2 '((0 8 2 0 1 0 0 0 0)
+ (7 0 0 0 0 0 0 3 0)
+ (0 0 0 0 0 6 0 0 5)
+ (0 0 0 0 0 0 0 8 0)
+ (3 0 0 7 0 0 0 0 0)
+ (0 0 0 0 0 0 1 0 4)
+ (4 0 1 0 0 0 0 0 6)
+ (0 0 0 0 5 0 0 0 0)
+ (0 0 0 8 0 0 0 0 0)))
From abaine at common-lisp.net Sun Aug 19 15:07:42 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:07:42 -0400 (EDT)
Subject: [funds-cvs] r149 - trunk/funds/src/examples
Message-ID: <20070819150742.4C526431B7@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:07:40 2007
New Revision: 149
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Renamed solve do puzzle-solve and added (solve list).
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sun Aug 19 11:07:40 2007
@@ -4,6 +4,9 @@
(defconstant +false+ 0)
(defconstant +true+ 1)
+(defun solve (list)
+ (list-from-puzzle (puzzle-solve (puzzle-from-list list))))
+
(defstruct puzzle
size
tree)
@@ -125,7 +128,7 @@
(collect (or (puzzle-elt puzzle i j k)
"")))))))))
-(defun solve (puzzle)
+(defun puzzle-solve (puzzle)
(if (puzzle-solvable-p puzzle)
(if (puzzle-complete-p puzzle)
puzzle
@@ -174,7 +177,7 @@
(funcall x-y-z-function x y z size)
(if (puzzle-elt puzzle i j k)
(f (1+ z))
- (or (solve (fill-true puzzle i j k))
+ (or (puzzle-solve (fill-true puzzle i j k))
(f (1+ z))))))))
(f 0))))
From abaine at common-lisp.net Sun Aug 19 15:25:39 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:25:39 -0400 (EDT)
Subject: [funds-cvs] r150 - in trunk/funds/src: heap trees/heap
Message-ID: <20070819152539.428E63700E@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:25:39 2007
New Revision: 150
Added:
trunk/funds/src/heap/
- copied from r149, trunk/funds/src/trees/heap/
Removed:
trunk/funds/src/trees/heap/
Log:
Moved heap to top directory.
From abaine at common-lisp.net Sun Aug 19 15:28:00 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:28:00 -0400 (EDT)
Subject: [funds-cvs] r151 - trunk/funds/src
Message-ID: <20070819152800.6C8087E005@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:28:00 2007
New Revision: 151
Modified:
trunk/funds/src/funds.asd
Log:
Moved heap module in defsystem.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Sun Aug 19 11:28:00 2007
@@ -40,14 +40,14 @@
(:file "tree-remove")
(:file "tree-find")
(:file "tree-weight")
- (:file "tree-height")
- (:module heap
- :serial t
- :components ((:file "heap")
- (:file "heap-empty-p")
- (:file "heap-insert")
- (:file "heap-remove")
- (:file "heap-first")))))
+ (:file "tree-height")))
+ (:module heap
+ :serial t
+ :components ((:file "heap")
+ (:file "heap-empty-p")
+ (:file "heap-insert")
+ (:file "heap-remove")
+ (:file "heap-first")))
(:file "f-array")
(:file "dictionary")
(:file "queue")))
From abaine at common-lisp.net Sun Aug 19 15:30:24 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:30:24 -0400 (EDT)
Subject: [funds-cvs] r152 - trunk/funds/src/trees
Message-ID: <20070819153024.9D9FB7E005@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:30:24 2007
New Revision: 152
Modified:
trunk/funds/src/trees/classes.lisp
Log:
Cosmetic changes.
Modified: trunk/funds/src/trees/classes.lisp
==============================================================================
--- trunk/funds/src/trees/classes.lisp (original)
+++ trunk/funds/src/trees/classes.lisp Sun Aug 19 11:30:24 2007
@@ -55,7 +55,3 @@
(left :initform (make-heap))
(right :initform (make-heap))
(weight :initarg :weight :initform 1 :reader heap-weight)))
-
-
-
-
From abaine at common-lisp.net Sun Aug 19 15:37:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:37:56 -0400 (EDT)
Subject: [funds-cvs] r153 - in trunk/funds/src: heap trees
Message-ID: <20070819153756.268F27E008@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:37:55 2007
New Revision: 153
Modified:
trunk/funds/src/heap/heap.lisp
trunk/funds/src/trees/classes.lisp
Log:
Moved heap classes from trees/classes.lisp to heap/heap.lisp.
Modified: trunk/funds/src/heap/heap.lisp
==============================================================================
--- trunk/funds/src/heap/heap.lisp (original)
+++ trunk/funds/src/heap/heap.lisp Sun Aug 19 11:37:55 2007
@@ -1,6 +1,16 @@
(in-package :funds)
+(defclass heap-leaf (leaf)
+ ()
+ (:documentation "A leaf node of a heap."))
+
+(defclass heap (binary-tree)
+ ((key :initarg :priority :reader heap-priority)
+ (left :initform (make-heap))
+ (right :initform (make-heap))
+ (weight :initarg :weight :initform 1 :reader heap-weight)))
+
(defun make-heap (&key (priority 0 p-p) value
(left (make-heap-leaf)) (right (make-heap-leaf)))
(if p-p
Modified: trunk/funds/src/trees/classes.lisp
==============================================================================
--- trunk/funds/src/trees/classes.lisp (original)
+++ trunk/funds/src/trees/classes.lisp Sun Aug 19 11:37:55 2007
@@ -45,13 +45,3 @@
(left :initform (make-avl-tree))
(right :initform (make-avl-tree)))
(:documentation "A height-balanced binary tree."))
-
-(defclass heap-leaf (leaf)
- ()
- (:documentation "A leaf node of a heap."))
-
-(defclass heap (binary-tree)
- ((key :initarg :priority :reader heap-priority)
- (left :initform (make-heap))
- (right :initform (make-heap))
- (weight :initarg :weight :initform 1 :reader heap-weight)))
From abaine at common-lisp.net Sun Aug 19 15:50:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:50:29 -0400 (EDT)
Subject: [funds-cvs] r154 - trunk/funds/src/trees
Message-ID: <20070819155029.660687E008@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:50:29 2007
New Revision: 154
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
superficiale
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Sun Aug 19 11:50:29 2007
@@ -33,7 +33,6 @@
(declare (ignore test order))
(stitch-avl-tree :key key :value value))
-
(defmethod tree-insert (tree key value &key (test #'eql) (order #'<))
(if (funcall test key (bt-key tree))
(stitch-tree tree :key key :value value :left (bt-left tree) :right (bt-right tree))
From abaine at common-lisp.net Sun Aug 19 15:53:04 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 11:53:04 -0400 (EDT)
Subject: [funds-cvs] r155 - in trunk/funds/src: heap trees
Message-ID: <20070819155304.2A11F7E00F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 11:53:04 2007
New Revision: 155
Modified:
trunk/funds/src/heap/heap.lisp
trunk/funds/src/trees/constructors.lisp
Log:
Moved +heap-leaf+ and make-heap-leaf from constructors.lisp to heap.lisp.
Modified: trunk/funds/src/heap/heap.lisp
==============================================================================
--- trunk/funds/src/heap/heap.lisp (original)
+++ trunk/funds/src/heap/heap.lisp Sun Aug 19 11:53:04 2007
@@ -5,6 +5,11 @@
()
(:documentation "A leaf node of a heap."))
+(defconstant +heap-leaf+ (make-instance 'heap-leaf))
+
+(defun make-heap-leaf ()
+ +heap-leaf+)
+
(defclass heap (binary-tree)
((key :initarg :priority :reader heap-priority)
(left :initform (make-heap))
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Sun Aug 19 11:53:04 2007
@@ -19,7 +19,6 @@
(defconstant +bt-leaf+ (make-instance 'bt-leaf))
(defconstant +avl-leaf+ (make-instance 'avl-leaf))
-(defconstant +heap-leaf+ (make-instance 'heap-leaf))
(defun make-bt-leaf ()
+bt-leaf+)
@@ -27,9 +26,6 @@
(defun make-avl-leaf ()
+avl-leaf+)
-(defun make-heap-leaf ()
- +heap-leaf+)
-
(defun make-binary-tree ()
(make-bt-leaf))
From abaine at common-lisp.net Sun Aug 19 16:07:16 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:07:16 -0400 (EDT)
Subject: [funds-cvs] r156 - in trunk/funds/src: heap trees
Message-ID: <20070819160716.19F1672093@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:07:15 2007
New Revision: 156
Modified:
trunk/funds/src/heap/heap.lisp
trunk/funds/src/trees/tree-weight.lisp
Log:
Moved heap functions to heap folder.
Modified: trunk/funds/src/heap/heap.lisp
==============================================================================
--- trunk/funds/src/heap/heap.lisp (original)
+++ trunk/funds/src/heap/heap.lisp Sun Aug 19 12:07:15 2007
@@ -5,7 +5,7 @@
()
(:documentation "A leaf node of a heap."))
-(defconstant +heap-leaf+ (make-instance 'heap-leaf))
+(defvar +heap-leaf+ (make-instance 'heap-leaf))
(defun make-heap-leaf ()
+heap-leaf+)
@@ -32,3 +32,6 @@
:value (bt-value root)
:left left
:right right))
+
+(defmethod tree-weight ((tree heap))
+ (heap-weight tree))
Modified: trunk/funds/src/trees/tree-weight.lisp
==============================================================================
--- trunk/funds/src/trees/tree-weight.lisp (original)
+++ trunk/funds/src/trees/tree-weight.lisp Sun Aug 19 12:07:15 2007
@@ -28,5 +28,3 @@
(+ 1 (tree-weight (bt-left tree))
(tree-weight (bt-right tree))))
-(defmethod tree-weight ((tree heap))
- (heap-weight tree))
From abaine at common-lisp.net Sun Aug 19 16:09:48 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:09:48 -0400 (EDT)
Subject: [funds-cvs] r157 - trunk/funds/src/trees
Message-ID: <20070819160948.978F015@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:09:48 2007
New Revision: 157
Modified:
trunk/funds/src/trees/constructors.lisp
Log:
Added documentation to make-binary-tree and make-avl-tree.
Modified: trunk/funds/src/trees/constructors.lisp
==============================================================================
--- trunk/funds/src/trees/constructors.lisp (original)
+++ trunk/funds/src/trees/constructors.lisp Sun Aug 19 12:09:48 2007
@@ -27,8 +27,10 @@
+avl-leaf+)
(defun make-binary-tree ()
+ "An empty binary tree."
(make-bt-leaf))
(defun make-avl-tree ()
+ "An empty AVL tree."
(make-avl-leaf))
From abaine at common-lisp.net Sun Aug 19 16:14:01 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:14:01 -0400 (EDT)
Subject: [funds-cvs] r158 - trunk/funds/src/trees
Message-ID: <20070819161401.896011903D@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:14:01 2007
New Revision: 158
Modified:
trunk/funds/src/trees/tree-insert.lisp
Log:
Edited documentation of tree-insert.
Modified: trunk/funds/src/trees/tree-insert.lisp
==============================================================================
--- trunk/funds/src/trees/tree-insert.lisp (original)
+++ trunk/funds/src/trees/tree-insert.lisp Sun Aug 19 12:14:01 2007
@@ -19,11 +19,12 @@
(defgeneric tree-insert (tree key value &key test order)
(:documentation
-"A new tree similar to the given tree except that the given key and value
-are now associated with one another. If the given key is already contained
-in the tree, according to the test function, then the old value is replaced
-by the specified value. The order function specifies whether the given
-key-value pair should be inserted to the left or right of the given tree."))
+ "A new tree similar to the given tree except that the given key and
+value are now associated with one another. If the given key is already
+contained in the tree, according to the test function, then the old value
+is replaced by the specified value in the returned tree. The order function
+specifies whether the given key-value pair should be inserted to the left or
+right of the given tree. The given tree is not modified."))
(defmethod tree-insert ((tree bt-leaf) key value &key test order)
(declare (ignore test order))
From abaine at common-lisp.net Sun Aug 19 16:15:37 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:15:37 -0400 (EDT)
Subject: [funds-cvs] r159 - trunk/funds/src/trees
Message-ID: <20070819161537.6049E1D133@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:15:37 2007
New Revision: 159
Modified:
trunk/funds/src/trees/tree-find.lisp
Log:
Edited documentation of tree-find.
Modified: trunk/funds/src/trees/tree-find.lisp
==============================================================================
--- trunk/funds/src/trees/tree-find.lisp (original)
+++ trunk/funds/src/trees/tree-find.lisp Sun Aug 19 12:15:37 2007
@@ -28,7 +28,6 @@
if k maps to nil. But
(find t k) -> nil nil
-
if there is no mapping for k in the tree."))
(defmethod tree-find ((tree leaf) key &key test order)
From abaine at common-lisp.net Sun Aug 19 16:17:35 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:17:35 -0400 (EDT)
Subject: [funds-cvs] r160 - trunk/funds/src/heap
Message-ID: <20070819161735.C27801D15C@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:17:35 2007
New Revision: 160
Modified:
trunk/funds/src/heap/heap.lisp
Log:
Added documentation to make-heap.
Modified: trunk/funds/src/heap/heap.lisp
==============================================================================
--- trunk/funds/src/heap/heap.lisp (original)
+++ trunk/funds/src/heap/heap.lisp Sun Aug 19 12:17:35 2007
@@ -18,6 +18,7 @@
(defun make-heap (&key (priority 0 p-p) value
(left (make-heap-leaf)) (right (make-heap-leaf)))
+ "An empty binary heap."
(if p-p
(make-instance 'heap
:priority priority
From abaine at common-lisp.net Sun Aug 19 16:18:32 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:18:32 -0400 (EDT)
Subject: [funds-cvs] r161 - trunk/funds/src/heap
Message-ID: <20070819161832.9A4851D164@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:18:32 2007
New Revision: 161
Modified:
trunk/funds/src/heap/heap-empty-p.lisp
Log:
Documented heap-empty-p.
Modified: trunk/funds/src/heap/heap-empty-p.lisp
==============================================================================
--- trunk/funds/src/heap/heap-empty-p.lisp (original)
+++ trunk/funds/src/heap/heap-empty-p.lisp Sun Aug 19 12:18:32 2007
@@ -18,4 +18,5 @@
(in-package :funds)
(defun heap-empty-p (heap)
+ "Whether the given heap has any elements."
(tree-empty-p heap))
\ No newline at end of file
From abaine at common-lisp.net Sun Aug 19 16:20:19 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:20:19 -0400 (EDT)
Subject: [funds-cvs] r162 - trunk/funds/src/heap
Message-ID: <20070819162019.2B3DB1F009@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:20:17 2007
New Revision: 162
Modified:
trunk/funds/src/heap/heap-first.lisp
Log:
Documented heap-first.
Modified: trunk/funds/src/heap/heap-first.lisp
==============================================================================
--- trunk/funds/src/heap/heap-first.lisp (original)
+++ trunk/funds/src/heap/heap-first.lisp Sun Aug 19 12:20:17 2007
@@ -18,4 +18,5 @@
(in-package :funds)
(defun heap-first (heap)
+ "The first value on the given heap."
(bt-value heap))
From abaine at common-lisp.net Sun Aug 19 16:22:02 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:22:02 -0400 (EDT)
Subject: [funds-cvs] r163 - trunk/funds/src/heap
Message-ID: <20070819162202.CE08A1F009@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:22:02 2007
New Revision: 163
Modified:
trunk/funds/src/heap/heap-insert.lisp
Log:
Documented heap-insert.
Modified: trunk/funds/src/heap/heap-insert.lisp
==============================================================================
--- trunk/funds/src/heap/heap-insert.lisp (original)
+++ trunk/funds/src/heap/heap-insert.lisp Sun Aug 19 12:22:02 2007
@@ -25,6 +25,9 @@
:value value))
(defmethod heap-insert (heap value priority &key (order #'<))
+ "A new heap, similar to the given heap, except that the priority-value
+pair is inserted into the retured heap according to the standard heap
+insertion algorithm."
(let* ((side (next-direction heap))
(other-side (other-side side))
(h1 (heap-insert (tree-child heap :side side) value priority
From abaine at common-lisp.net Sun Aug 19 16:27:37 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:27:37 -0400 (EDT)
Subject: [funds-cvs] r164 - trunk/funds/src/heap
Message-ID: <20070819162737.EB3F525002@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:27:37 2007
New Revision: 164
Modified:
trunk/funds/src/heap/heap-remove.lisp
Log:
Documented heap-remove.
Modified: trunk/funds/src/heap/heap-remove.lisp
==============================================================================
--- trunk/funds/src/heap/heap-remove.lisp (original)
+++ trunk/funds/src/heap/heap-remove.lisp Sun Aug 19 12:27:37 2007
@@ -17,6 +17,10 @@
(in-package :funds)
+(defgeneric heap-remove (heap &key order)
+ (:documentation "The heap that results when first value is removed
+from the given heap."))
+
(defmethod heap-remove ((heap heap-leaf) &key order)
(declare (ignore order))
heap)
From abaine at common-lisp.net Sun Aug 19 16:30:29 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:30:29 -0400 (EDT)
Subject: [funds-cvs] r165 - trunk/funds/src
Message-ID: <20070819163029.2480E2D166@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:30:28 2007
New Revision: 165
Modified:
trunk/funds/src/queue.lisp
Log:
Documented queue.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Sun Aug 19 12:30:28 2007
@@ -18,6 +18,7 @@
(in-package :funds)
(defstruct queue
+ "A FIFO queue."
(next-priority 0)
(heap (make-heap)))
From abaine at common-lisp.net Sun Aug 19 16:36:10 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:36:10 -0400 (EDT)
Subject: [funds-cvs] r166 - trunk/funds/src/trees
Message-ID: <20070819163610.888C82D166@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:36:10 2007
New Revision: 166
Modified:
trunk/funds/src/trees/tree-empty-p.lisp
Log:
Edited documentation.
Modified: trunk/funds/src/trees/tree-empty-p.lisp
==============================================================================
--- trunk/funds/src/trees/tree-empty-p.lisp (original)
+++ trunk/funds/src/trees/tree-empty-p.lisp Sun Aug 19 12:36:10 2007
@@ -19,8 +19,7 @@
(defgeneric tree-empty-p (tree)
(:documentation
-"Whether this tree has any key-value pairs."))
-
+"Whether the given tree does not contain key-value pairs."))
(defmethod tree-empty-p ((tree t))
nil)
From abaine at common-lisp.net Sun Aug 19 16:38:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:38:18 -0400 (EDT)
Subject: [funds-cvs] r167 - trunk/funds/src
Message-ID: <20070819163818.F0F3F2D01D@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:38:18 2007
New Revision: 167
Modified:
trunk/funds/src/queue.lisp
Log:
Documented queue functions.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Sun Aug 19 12:38:18 2007
@@ -23,20 +23,25 @@
(heap (make-heap)))
(defun queue-first (q)
+ "The value at the head of the given queue."
(heap-first (queue-heap q)))
(defun queue-enqueue (q item)
+ "The queue that results when the given item is equeued on the given queue."
(make-queue :next-priority (1+ (queue-next-priority q))
:heap (heap-insert (queue-heap q) item (queue-next-priority q))))
(defun queue-dequeue (q)
+ "The queue that results when the first item is removed from the given queue."
(if (queue-empty-p q)
q
(make-queue :next-priority (1- (queue-next-priority q))
:heap (heap-remove (queue-heap q)))))
(defun queue-size (q)
+ "The number of items in the given queue."
(tree-weight (queue-heap q)))
(defun queue-empty-p (q)
+ "Whether the given queue does not contain any items."
(tree-empty-p (queue-heap q)))
From abaine at common-lisp.net Sun Aug 19 16:40:17 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:40:17 -0400 (EDT)
Subject: [funds-cvs] r168 - trunk/funds/src/stack
Message-ID: <20070819164017.5281D2D01D@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:40:17 2007
New Revision: 168
Removed:
trunk/funds/src/stack/
Log:
Removed stack directory.
From abaine at common-lisp.net Sun Aug 19 16:46:28 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:46:28 -0400 (EDT)
Subject: [funds-cvs] r169 - trunk/funds/src
Message-ID: <20070819164628.9AF342D077@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:46:27 2007
New Revision: 169
Modified:
trunk/funds/src/dictionary.lisp
Log:
Documented dictionary.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Sun Aug 19 12:46:27 2007
@@ -7,9 +7,14 @@
tree)
(defun make-dictionary (&key (hash #'sxhash) (test #'eql))
+ "An empty dictionary that hashes occording to the given hash function,
+which defaults to #'sxhash and and tests according to the given test
+function, which defaults to #'eql."
(make-dict :hash hash :test test :tree (make-avl-tree)))
(defun dictionary-add (d k v)
+ "A dictionary similar to the given dictionary except that k maps to
+v in the returned dictionary."
(let* ((h (funcall (dict-hash d) k))
(old-alist (tree-find (dict-tree d) h))
(new-alist (acons k v (remove (assoc k old-alist :test (dict-test d))
@@ -19,6 +24,8 @@
:tree (tree-insert (dict-tree d) h new-alist))))
(defun dictionary-remove (d k)
+ "A dictionary similar to the given dictionary, except that k does
+not map to any value in the returned dictionary."
(let* ((h (funcall (dict-hash d) k))
(old-alist (tree-find (dict-tree d) h))
(new-alist (remove (assoc k old-alist :test (dict-test d))
@@ -30,6 +37,9 @@
(tree-insert (dict-tree d) h new-alist)))))
(defun dictionary-lookup (d k)
+ "The value associated with the given key in the given dictionary. A second
+value is returned to indicate whether the key is associated with any value or
+is not found."
(let ((pair (assoc k
(tree-find (dict-tree d) (funcall (dict-hash d) k))
:test (dict-test d))))
From abaine at common-lisp.net Sun Aug 19 16:57:02 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:57:02 -0400 (EDT)
Subject: [funds-cvs] r170 - trunk/funds/src
Message-ID: <20070819165702.EE3952D18F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:57:02 2007
New Revision: 170
Modified:
trunk/funds/src/f-array.lisp
Log:
Documented f-array.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Sun Aug 19 12:57:02 2007
@@ -2,6 +2,7 @@
(in-package :funds)
(defun make-f-array (size &key (initial-contents nil))
+ "A functional array of the given size with the given initial contents."
(let ((length (length initial-contents)))
(labels ((f (start end)
(if (= start end)
@@ -16,12 +17,16 @@
(f 0 size))))
(defun f-array-elt (array index)
+ "The element at the given index of the given array."
(tree-find array index :test #'=))
-(defun f-array-replace (array index item)
- (tree-insert array index item :test #'=))
+(defun f-array-replace (array index element)
+ "An array similar to the given array except that index and element are
+associated in the returned array."
+ (tree-insert array index element :test #'=))
(defun f-array-size (array)
+ "The number of elements in the given array."
(labels ((f (tree amount)
(if (tree-empty-p tree)
amount
From abaine at common-lisp.net Sun Aug 19 16:58:53 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 12:58:53 -0400 (EDT)
Subject: [funds-cvs] r171 - trunk/funds/src
Message-ID: <20070819165853.9F1952D1A0@common-lisp.net>
Author: abaine
Date: Sun Aug 19 12:58:53 2007
New Revision: 171
Modified:
trunk/funds/src/package.lisp
Log:
Exported dictionary-as-alist.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 12:58:53 2007
@@ -52,6 +52,7 @@
:dictionary-add
:dictionary-remove
:dictionary-lookup
+ :dictionary-as-alist
:make-f-array
:f-array-elt
From abaine at common-lisp.net Sun Aug 19 17:34:53 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 13:34:53 -0400 (EDT)
Subject: [funds-cvs] r172 - trunk/funds/src
Message-ID: <20070819173453.D291D70C1@common-lisp.net>
Author: abaine
Date: Sun Aug 19 13:34:53 2007
New Revision: 172
Modified:
trunk/funds/src/dictionary.lisp
Log:
Added dictionary-as-alist.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Sun Aug 19 13:34:53 2007
@@ -47,3 +47,12 @@
(values nil nil)
(values (cdr pair) t))))
+(defun dictionary-as-alist (d)
+ "An alist containing the same key-value pairs as the given dictionary."
+ (labels ((f (tree)
+ (if (tree-empty-p tree)
+ nil
+ (append (f (bt-left tree))
+ (bt-value tree)
+ (f (bt-right tree))))))
+ (f (dict-tree d))))
From abaine at common-lisp.net Sun Aug 19 21:22:13 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 17:22:13 -0400 (EDT)
Subject: [funds-cvs] r173 - trunk/funds/src
Message-ID: <20070819212213.3BA8B830B0@common-lisp.net>
Author: abaine
Date: Sun Aug 19 17:22:12 2007
New Revision: 173
Modified:
trunk/funds/src/funds.asd
Log:
Added utilities to defsystem.
Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd (original)
+++ trunk/funds/src/funds.asd Sun Aug 19 17:22:12 2007
@@ -40,7 +40,8 @@
(:file "tree-remove")
(:file "tree-find")
(:file "tree-weight")
- (:file "tree-height")))
+ (:file "tree-height")
+ (:file "utilities")))
(:module heap
:serial t
:components ((:file "heap")
From abaine at common-lisp.net Sun Aug 19 21:22:40 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 17:22:40 -0400 (EDT)
Subject: [funds-cvs] r174 - trunk/funds/src/trees
Message-ID: <20070819212240.33531830B0@common-lisp.net>
Author: abaine
Date: Sun Aug 19 17:22:39 2007
New Revision: 174
Added:
trunk/funds/src/trees/utilities.lisp
Log:
Added tree-count and tree-count-if.
Added: trunk/funds/src/trees/utilities.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/trees/utilities.lisp Sun Aug 19 17:22:39 2007
@@ -0,0 +1,18 @@
+
+(in-package :funds)
+
+(defun tree-count (item tree &key (key #'bt-value) (test #'eql))
+ "The number of sub-trees in the tree that satisfy the test."
+ (tree-count #'(lambda (x)
+ (funcall test x item))
+ :key key))
+
+(defun tree-count-if (predicate tree &key (key #'bt-value))
+ "The number of sub-trees in the given tree that satisfy the test."
+ (if (tree-empty-p tree)
+ 0
+ (+ (tree-count-if predicate (bt-left tree) :key key)
+ (funcall predicate (funcall key tree))
+ (tree-count-if predicate (bt-right tree) :key key))))
+
+
From abaine at common-lisp.net Sun Aug 19 21:45:44 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 17:45:44 -0400 (EDT)
Subject: [funds-cvs] r175 - trunk/funds/src
Message-ID: <20070819214544.597C26F243@common-lisp.net>
Author: abaine
Date: Sun Aug 19 17:45:44 2007
New Revision: 175
Modified:
trunk/funds/src/package.lisp
Log:
Exported tree-as-alist, tree-count, and tree-count-if.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 17:45:44 2007
@@ -28,6 +28,9 @@
:tree-empty-p
:tree-height
:tree-weight
+ :tree-as-alist
+ :tree-count
+ :tree-count-if
:make-heap
:heap-empty-p
From abaine at common-lisp.net Sun Aug 19 21:46:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 17:46:09 -0400 (EDT)
Subject: [funds-cvs] r176 - trunk/funds/src/trees
Message-ID: <20070819214609.F10E46F243@common-lisp.net>
Author: abaine
Date: Sun Aug 19 17:46:09 2007
New Revision: 176
Modified:
trunk/funds/src/trees/utilities.lisp
Log:
Fixed tree-count and tree-count-if.
Modified: trunk/funds/src/trees/utilities.lisp
==============================================================================
--- trunk/funds/src/trees/utilities.lisp (original)
+++ trunk/funds/src/trees/utilities.lisp Sun Aug 19 17:46:09 2007
@@ -1,18 +1,18 @@
(in-package :funds)
-(defun tree-count (item tree &key (key #'bt-value) (test #'eql))
+(defun tree-count (item tree &key (key #'identity) (test #'eql))
"The number of sub-trees in the tree that satisfy the test."
- (tree-count #'(lambda (x)
- (funcall test x item))
- :key key))
+ (tree-count-if #'(lambda (x) (funcall test x item))
+ tree
+ :key key))
-(defun tree-count-if (predicate tree &key (key #'bt-value))
+(defun tree-count-if (predicate tree &key (key #'identity))
"The number of sub-trees in the given tree that satisfy the test."
(if (tree-empty-p tree)
0
(+ (tree-count-if predicate (bt-left tree) :key key)
- (funcall predicate (funcall key tree))
+ (if (funcall predicate (funcall key tree))
+ 1
+ 0)
(tree-count-if predicate (bt-right tree) :key key))))
-
-
From abaine at common-lisp.net Mon Aug 20 01:04:26 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:04:26 -0400 (EDT)
Subject: [funds-cvs] r177 - trunk/funds/src/examples
Message-ID: <20070820010426.32A74650DC@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:04:25 2007
New Revision: 177
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Removed stupid 'optimization' from solver.
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sun Aug 19 21:04:25 2007
@@ -135,8 +135,6 @@
(iter (for f in x-y-z-functions)
(for (values x y n) = (best-group puzzle f))
(finding (list f x y) minimizing n into (best-list min))
- (when (= min 1)
- (return (apply #'solve-group puzzle best-list)))
(finally (return (apply #'solve-group puzzle best-list)))))
nil))
@@ -147,13 +145,9 @@
(iter (for y below size)
(for n = (group-freedom puzzle x-y-z-function x y))
(finding y minimizing n into (best-y min))
- (when (= min 1)
- (return (values best-y min)))
(finally (return (values best-y min)))))
(finding x minimizing n into best-x)
(finding y minimizing n into (best-y best-n))
- (when (= best-n 1)
- (return (values best-x best-y best-n)))
(finally (return (values best-x best-y best-n))))))
(defun group-freedom (puzzle x-y-z-function x y)
From abaine at common-lisp.net Mon Aug 20 01:18:02 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:18:02 -0400 (EDT)
Subject: [funds-cvs] r178 - trunk/funds/src
Message-ID: <20070820011802.01B716510B@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:18:02 2007
New Revision: 178
Modified:
trunk/funds/src/package.lisp
Log:
Exported bt-key and bt-value.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 21:18:02 2007
@@ -22,6 +22,9 @@
(:export :make-avl-tree
:make-binary-tree
+ :bt-key
+ :bt-value
+
:tree-insert
:tree-remove
:tree-find
From abaine at common-lisp.net Mon Aug 20 01:21:46 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:21:46 -0400 (EDT)
Subject: [funds-cvs] r179 - trunk/funds/src/examples
Message-ID: <20070820012146.561956510B@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:21:46 2007
New Revision: 179
Modified:
trunk/funds/src/examples/sudoku.lisp
Log:
Simplified solver, somehow slowing it down!
Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp (original)
+++ trunk/funds/src/examples/sudoku.lisp Sun Aug 19 21:21:46 2007
@@ -46,11 +46,8 @@
(round (expt (puzzle-size puzzle) 3))))
(defun puzzle-solved-p (puzzle)
- (let ((size (puzzle-size puzzle)))
- (iter (for x below size)
- (always (iter (for y below size)
- (always (iter (for f in x-y-z-functions)
- (always (group-solved puzzle f x y)))))))))
+ (= (round (expt (puzzle-size puzzle) 2))
+ (tree-count +true+ (puzzle-tree puzzle) :key #'bt-value :test #'=)))
(defun puzzle-solvable-p (puzzle)
(let ((size (puzzle-size puzzle)))
@@ -129,14 +126,12 @@
"")))))))))
(defun puzzle-solve (puzzle)
- (if (puzzle-solvable-p puzzle)
- (if (puzzle-complete-p puzzle)
- puzzle
- (iter (for f in x-y-z-functions)
- (for (values x y n) = (best-group puzzle f))
- (finding (list f x y) minimizing n into (best-list min))
- (finally (return (apply #'solve-group puzzle best-list)))))
- nil))
+ (if (puzzle-complete-p puzzle)
+ puzzle
+ (iter (for f in x-y-z-functions)
+ (for (values x y n) = (best-group puzzle f))
+ (finding (list f x y) minimizing n into (best-list min))
+ (finally (return (apply #'solve-group puzzle best-list))))))
(defun best-group (puzzle x-y-z-function)
(let ((size (puzzle-size puzzle)))
From abaine at common-lisp.net Mon Aug 20 01:38:24 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:38:24 -0400 (EDT)
Subject: [funds-cvs] r180 - trunk/funds/src/trees
Message-ID: <20070820013824.66B766511F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:38:24 2007
New Revision: 180
Modified:
trunk/funds/src/trees/utilities.lisp
Log:
Added map-tree.
Modified: trunk/funds/src/trees/utilities.lisp
==============================================================================
--- trunk/funds/src/trees/utilities.lisp (original)
+++ trunk/funds/src/trees/utilities.lisp Sun Aug 19 21:38:24 2007
@@ -16,3 +16,12 @@
1
0)
(tree-count-if predicate (bt-right tree) :key key))))
+
+(defun map-tree (function tree)
+ (if (tree-empty-p tree)
+ tree
+ (stitch-tree tree
+ :value (funcall function tree)
+ :left (map-tree function (bt-left tree))
+ :right (map-tree function (bt-right tree)))))
+
From abaine at common-lisp.net Mon Aug 20 01:40:11 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:40:11 -0400 (EDT)
Subject: [funds-cvs] r181 - trunk/funds/src
Message-ID: <20070820014011.67BFD6511F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:40:08 2007
New Revision: 181
Modified:
trunk/funds/src/package.lisp
Log:
Exported map-tree.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 21:40:08 2007
@@ -34,6 +34,7 @@
:tree-as-alist
:tree-count
:tree-count-if
+ :map-tree
:make-heap
:heap-empty-p
From abaine at common-lisp.net Mon Aug 20 01:41:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:41:18 -0400 (EDT)
Subject: [funds-cvs] r182 - trunk/funds/src/trees
Message-ID: <20070820014118.D73506511F@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:41:18 2007
New Revision: 182
Modified:
trunk/funds/src/trees/utilities.lisp
Log:
Documented map-tree.
Modified: trunk/funds/src/trees/utilities.lisp
==============================================================================
--- trunk/funds/src/trees/utilities.lisp (original)
+++ trunk/funds/src/trees/utilities.lisp Sun Aug 19 21:41:18 2007
@@ -18,6 +18,8 @@
(tree-count-if predicate (bt-right tree) :key key))))
(defun map-tree (function tree)
+ "A tree each node of which corresponds to the application of
+function to one node of the given tree."
(if (tree-empty-p tree)
tree
(stitch-tree tree
From abaine at common-lisp.net Mon Aug 20 01:49:51 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:49:51 -0400 (EDT)
Subject: [funds-cvs] r183 - trunk/funds/src
Message-ID: <20070820014951.A4A186F24B@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:49:51 2007
New Revision: 183
Modified:
trunk/funds/src/stack.lisp
Log:
Added map-stack.
Modified: trunk/funds/src/stack.lisp
==============================================================================
--- trunk/funds/src/stack.lisp (original)
+++ trunk/funds/src/stack.lisp Sun Aug 19 21:49:51 2007
@@ -44,3 +44,8 @@
accum
(f (stack-pop stack) (1+ accum)))))
(f stack 0)))
+
+(defun map-stack (function stack)
+ "A stack whose elements are those of the given stack when function is applied
+to them."
+ (mapcar function stack))
\ No newline at end of file
From abaine at common-lisp.net Mon Aug 20 01:50:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 21:50:56 -0400 (EDT)
Subject: [funds-cvs] r184 - trunk/funds/src
Message-ID: <20070820015056.016AE72086@common-lisp.net>
Author: abaine
Date: Sun Aug 19 21:50:55 2007
New Revision: 184
Modified:
trunk/funds/src/package.lisp
Log:
Exported map-stack and map-queue.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 21:50:55 2007
@@ -48,12 +48,14 @@
:queue-dequeue
:queue-first
:queue-size
+ :map-queue
:make-stack
:stack-empty-p
:stack-push
:stack-top
:stack-size
+ :map-stack
:make-dictionary
:dictionary-add
From abaine at common-lisp.net Mon Aug 20 02:07:40 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 22:07:40 -0400 (EDT)
Subject: [funds-cvs] r185 - trunk/funds/src
Message-ID: <20070820020740.AACA91C0BA@common-lisp.net>
Author: abaine
Date: Sun Aug 19 22:07:40 2007
New Revision: 185
Modified:
trunk/funds/src/queue.lisp
Log:
Added map-queue and queue-as-list.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Sun Aug 19 22:07:40 2007
@@ -45,3 +45,17 @@
(defun queue-empty-p (q)
"Whether the given queue does not contain any items."
(tree-empty-p (queue-heap q)))
+
+(defun map-queue (function q)
+ "A queue containing items that are the result of applying function to
+the items in the given queue."
+ (make-queue :next-priority (queue-next-priority q)
+ :heap (map-tree #'(lambda (tree)
+ (funcall function (bt-value tree)))
+ (queue-heap q))))
+
+(defun queue-as-list (q)
+ "The elements in the given queue, returned as a list, in the order they
+would be dequeued from the given queue."
+ (mapcar #'cdr (sort (tree-as-alist (queue-heap q))
+ #'< :key #'car)))
From abaine at common-lisp.net Mon Aug 20 02:20:08 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Sun, 19 Aug 2007 22:20:08 -0400 (EDT)
Subject: [funds-cvs] r186 - trunk/funds/src
Message-ID: <20070820022008.6D8211D125@common-lisp.net>
Author: abaine
Date: Sun Aug 19 22:20:06 2007
New Revision: 186
Modified:
trunk/funds/src/package.lisp
Log:
Exported queue-as-list.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Sun Aug 19 22:20:06 2007
@@ -48,6 +48,7 @@
:queue-dequeue
:queue-first
:queue-size
+ :queue-as-list
:map-queue
:make-stack
From abaine at common-lisp.net Mon Aug 20 15:40:04 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:40:04 -0400 (EDT)
Subject: [funds-cvs] r187 - trunk/funds/src
Message-ID: <20070820154004.B45AD72093@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:40:04 2007
New Revision: 187
Modified:
trunk/funds/src/queue.lisp
Log:
Added queue-from-list.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 11:40:04 2007
@@ -59,3 +59,10 @@
would be dequeued from the given queue."
(mapcar #'cdr (sort (tree-as-alist (queue-heap q))
#'< :key #'car)))
+
+(defun queue-from-list (list)
+ "A queue whose elements are in the same order as the given list."
+ (reduce #'(lambda (q n)
+ (queue-enqueue q n))
+ list
+ :initial-value (make-queue)))
From abaine at common-lisp.net Mon Aug 20 15:40:20 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:40:20 -0400 (EDT)
Subject: [funds-cvs] r188 - trunk/funds/src
Message-ID: <20070820154020.91F7372093@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:40:20 2007
New Revision: 188
Modified:
trunk/funds/src/package.lisp
Log:
Exported queue-from-list.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 11:40:20 2007
@@ -49,6 +49,7 @@
:queue-first
:queue-size
:queue-as-list
+ :queue-from-list
:map-queue
:make-stack
From abaine at common-lisp.net Mon Aug 20 15:42:10 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:42:10 -0400 (EDT)
Subject: [funds-cvs] r189 - trunk/funds/src
Message-ID: <20070820154210.012DE72093@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:42:10 2007
New Revision: 189
Modified:
trunk/funds/src/package.lisp
trunk/funds/src/stack.lisp
Log:
Added and exported stack-as-list and stack-from-list.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 11:42:10 2007
@@ -57,6 +57,8 @@
:stack-push
:stack-top
:stack-size
+ :stack-from-list
+ :stack-as-list
:map-stack
:make-dictionary
Modified: trunk/funds/src/stack.lisp
==============================================================================
--- trunk/funds/src/stack.lisp (original)
+++ trunk/funds/src/stack.lisp Mon Aug 20 11:42:10 2007
@@ -48,4 +48,14 @@
(defun map-stack (function stack)
"A stack whose elements are those of the given stack when function is applied
to them."
- (mapcar function stack))
\ No newline at end of file
+ (mapcar function stack))
+
+(defun stack-from-list (list)
+ "This function is here in case the implementation of stack changes from what
+it is now, a list."
+ list)
+
+(defun stack-as-list (stack)
+ "This function is here in case the implementation of stack changes from what
+it is now, a list."
+ stack)
\ No newline at end of file
From abaine at common-lisp.net Mon Aug 20 15:48:04 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:48:04 -0400 (EDT)
Subject: [funds-cvs] r190 - trunk/funds/src
Message-ID: <20070820154804.B3D2E72095@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:48:04 2007
New Revision: 190
Modified:
trunk/funds/src/dictionary.lisp
trunk/funds/src/package.lisp
Log:
Added and exported dictionary-from-alist.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Mon Aug 20 11:48:04 2007
@@ -56,3 +56,9 @@
(bt-value tree)
(f (bt-right tree))))))
(f (dict-tree d))))
+
+(defun dictionary-from-alist (alist)
+ (reduce #'(lambda (d pair)
+ (dictionary-add d (car pair) (cdr pair)))
+ alist
+ :initial-value (make-dictionary)))
\ No newline at end of file
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 11:48:04 2007
@@ -66,6 +66,7 @@
:dictionary-remove
:dictionary-lookup
:dictionary-as-alist
+ :dictionary-from-alist
:make-f-array
:f-array-elt
From abaine at common-lisp.net Mon Aug 20 15:54:26 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:54:26 -0400 (EDT)
Subject: [funds-cvs] r191 - trunk/funds/src
Message-ID: <20070820155426.A0D15100A@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:54:26 2007
New Revision: 191
Modified:
trunk/funds/src/package.lisp
trunk/funds/src/queue.lisp
Log:
Renamed enqueue and dequeue.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 11:54:26 2007
@@ -44,8 +44,8 @@
:make-queue
:queue-empty-p
- :queue-enqueue
- :queue-dequeue
+ :enqueue
+ :dequeue
:queue-first
:queue-size
:queue-as-list
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 11:54:26 2007
@@ -26,12 +26,12 @@
"The value at the head of the given queue."
(heap-first (queue-heap q)))
-(defun queue-enqueue (q item)
+(defun enqueue (q item)
"The queue that results when the given item is equeued on the given queue."
(make-queue :next-priority (1+ (queue-next-priority q))
:heap (heap-insert (queue-heap q) item (queue-next-priority q))))
-(defun queue-dequeue (q)
+(defun dequeue (q)
"The queue that results when the first item is removed from the given queue."
(if (queue-empty-p q)
q
From abaine at common-lisp.net Mon Aug 20 15:56:45 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 11:56:45 -0400 (EDT)
Subject: [funds-cvs] r192 - trunk/funds/src
Message-ID: <20070820155645.AF7BE100A@common-lisp.net>
Author: abaine
Date: Mon Aug 20 11:56:45 2007
New Revision: 192
Modified:
trunk/funds/src/queue.lisp
Log:
Fixed enqueue naming.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 11:56:45 2007
@@ -63,6 +63,6 @@
(defun queue-from-list (list)
"A queue whose elements are in the same order as the given list."
(reduce #'(lambda (q n)
- (queue-enqueue q n))
+ (enqueue q n))
list
:initial-value (make-queue)))
From abaine at common-lisp.net Mon Aug 20 16:30:56 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:30:56 -0400 (EDT)
Subject: [funds-cvs] r193 - trunk/funds/src
Message-ID: <20070820163056.659AC9@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:30:56 2007
New Revision: 193
Modified:
trunk/funds/src/package.lisp
trunk/funds/src/queue.lisp
Log:
Substituted alternative version of queue using CLOS; I had been developing this in parallel and it makes more sense, I thirk.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 12:30:56 2007
@@ -49,7 +49,8 @@
:queue-first
:queue-size
:queue-as-list
- :queue-from-list
+ :queue-count
+ :queue-count-if
:map-queue
:make-stack
@@ -59,6 +60,8 @@
:stack-size
:stack-from-list
:stack-as-list
+ :stack-count
+ :stack-count-if
:map-stack
:make-dictionary
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 12:30:56 2007
@@ -17,10 +17,19 @@
(in-package :funds)
-(defstruct queue
- "A FIFO queue."
- (next-priority 0)
- (heap (make-heap)))
+(defclass queue ()
+ ((next-priority :initarg :next-priority
+ :initform 0
+ :reader queue-next-priority)
+ (heap :initarg :heap
+ :initform (make-heap)
+ :reader queue-heap)))
+
+(defun make-queue (&key (initial-contents nil))
+ (reduce #'(lambda (q n)
+ (enqueue q n))
+ initial-contents
+ :initial-value (make-instance 'queue)))
(defun queue-first (q)
"The value at the head of the given queue."
@@ -28,15 +37,15 @@
(defun enqueue (q item)
"The queue that results when the given item is equeued on the given queue."
- (make-queue :next-priority (1+ (queue-next-priority q))
- :heap (heap-insert (queue-heap q) item (queue-next-priority q))))
+ (make-instance 'queue :next-priority (1+ (queue-next-priority q))
+ :heap (heap-insert (queue-heap q) item (queue-next-priority q))))
(defun dequeue (q)
"The queue that results when the first item is removed from the given queue."
(if (queue-empty-p q)
q
- (make-queue :next-priority (1- (queue-next-priority q))
- :heap (heap-remove (queue-heap q)))))
+ (make-instance 'queue :next-priority (1- (queue-next-priority q))
+ :heap (heap-remove (queue-heap q)))))
(defun queue-size (q)
"The number of items in the given queue."
@@ -49,8 +58,8 @@
(defun map-queue (function q)
"A queue containing items that are the result of applying function to
the items in the given queue."
- (make-queue :next-priority (queue-next-priority q)
- :heap (map-tree #'(lambda (tree)
+ (make-instance 'queue :next-priority (queue-next-priority q)
+ :heap (map-tree #'(lambda (tree)
(funcall function (bt-value tree)))
(queue-heap q))))
@@ -60,9 +69,13 @@
(mapcar #'cdr (sort (tree-as-alist (queue-heap q))
#'< :key #'car)))
-(defun queue-from-list (list)
- "A queue whose elements are in the same order as the given list."
- (reduce #'(lambda (q n)
- (enqueue q n))
- list
- :initial-value (make-queue)))
+(defun queue-count (item q &key (key #'identity) (test #'eql))
+ (tree-count item (queue-heap q)
+ :key #'(lambda (tree)
+ (funcall key (bt-value tree)))
+ :test test))
+
+(defun queue-count-if (predicate q &key (key #'identity))
+ (tree-count-if predicate (queue-heap q)
+ :key #'(lambda (tree)
+ (funcall key (bt-value tree)))))
From abaine at common-lisp.net Mon Aug 20 16:33:28 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:33:28 -0400 (EDT)
Subject: [funds-cvs] r194 - trunk/funds/src
Message-ID: <20070820163328.6B8A015@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:33:28 2007
New Revision: 194
Modified:
trunk/funds/src/queue.lisp
Log:
Documented queue-count and queue-count-if.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 12:33:28 2007
@@ -70,12 +70,14 @@
#'< :key #'car)))
(defun queue-count (item q &key (key #'identity) (test #'eql))
+ "The number of elements in the given queue that satisfy the test."
(tree-count item (queue-heap q)
:key #'(lambda (tree)
(funcall key (bt-value tree)))
:test test))
(defun queue-count-if (predicate q &key (key #'identity))
+ "The number of elements in the given queue that satisfy the test."
(tree-count-if predicate (queue-heap q)
:key #'(lambda (tree)
(funcall key (bt-value tree)))))
From abaine at common-lisp.net Mon Aug 20 16:36:38 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:36:38 -0400 (EDT)
Subject: [funds-cvs] r195 - trunk/funds/src
Message-ID: <20070820163638.12DDD16@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:36:37 2007
New Revision: 195
Modified:
trunk/funds/src/stack.lisp
Log:
Added stack-count and stack-count-if.
Modified: trunk/funds/src/stack.lisp
==============================================================================
--- trunk/funds/src/stack.lisp (original)
+++ trunk/funds/src/stack.lisp Mon Aug 20 12:36:37 2007
@@ -58,4 +58,10 @@
(defun stack-as-list (stack)
"This function is here in case the implementation of stack changes from what
it is now, a list."
- stack)
\ No newline at end of file
+ stack)
+
+(defun stack-count (item stack &key (key #'identity) (test #'eql))
+ (count item stack :key key :test test))
+
+(defun stack-count-if (predicate stack &key (key #'identity))
+ (count-if predicate stack :key key))
From abaine at common-lisp.net Mon Aug 20 16:40:03 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:40:03 -0400 (EDT)
Subject: [funds-cvs] r196 - trunk/funds/src
Message-ID: <20070820164003.1936516@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:40:01 2007
New Revision: 196
Modified:
trunk/funds/src/package.lisp
Log:
Exported f-array-count f-array-count-if map-f-array.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 12:40:01 2007
@@ -74,4 +74,7 @@
:make-f-array
:f-array-elt
:f-array-replace
- :f-array-size))
+ :f-array-size
+ :f-array-count
+ :f-array-count-if
+ :map-f-array))
From abaine at common-lisp.net Mon Aug 20 16:57:15 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:57:15 -0400 (EDT)
Subject: [funds-cvs] r197 - trunk/funds/src
Message-ID: <20070820165715.60D1225002@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:57:15 2007
New Revision: 197
Modified:
trunk/funds/src/package.lisp
Log:
Exported f-array-as-list.
Modified: trunk/funds/src/package.lisp
==============================================================================
--- trunk/funds/src/package.lisp (original)
+++ trunk/funds/src/package.lisp Mon Aug 20 12:57:15 2007
@@ -75,6 +75,7 @@
:f-array-elt
:f-array-replace
:f-array-size
+ :f-array-as-list
:f-array-count
:f-array-count-if
:map-f-array))
From abaine at common-lisp.net Mon Aug 20 16:58:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 12:58:18 -0400 (EDT)
Subject: [funds-cvs] r198 - trunk/funds/src
Message-ID: <20070820165818.BA88128037@common-lisp.net>
Author: abaine
Date: Mon Aug 20 12:58:18 2007
New Revision: 198
Modified:
trunk/funds/src/f-array.lisp
Log:
Added f-array-count, f-array-count-if, map-f-array, and f-array-as-list; also added initial-element keyword to make-f-array.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Mon Aug 20 12:58:18 2007
@@ -1,7 +1,7 @@
(in-package :funds)
-(defun make-f-array (size &key (initial-contents nil))
+(defun make-f-array (size &key (initial-contents nil) (initial-element nil))
"A functional array of the given size with the given initial contents."
(let ((length (length initial-contents)))
(labels ((f (start end)
@@ -11,7 +11,7 @@
(make-instance 'binary-tree
:key midpoint :value (if (< start length)
(elt initial-contents midpoint)
- nil)
+ initial-element)
:left (f start midpoint)
:right (f (1+ midpoint) end))))))
(f 0 size))))
@@ -32,3 +32,22 @@
amount
(f (bt-right tree) (1+ (bt-key tree))))))
(f array 0)))
+
+(defun f-array-count (item f-array &key (key #'identity) (test #'eql))
+ (tree-count item f-array
+ :key #'(lambda (tree)
+ (funcall key (bt-value tree)))
+ :test test))
+
+(defun f-array-count-if (pred f-array &key (key #'identity))
+ (tree-count-if pred f-array
+ :key #'(lambda (tree)
+ (funcall key (bt-value tree)))))
+
+(defun map-f-array (function f-array)
+ (map-tree #'(lambda (tree)
+ (funcall function (bt-value tree)))
+ f-array))
+
+(defun f-array-as-list (f-array)
+ (mapcar #'cdr (tree-as-alist f-array)))
From abaine at common-lisp.net Mon Aug 20 17:09:57 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 13:09:57 -0400 (EDT)
Subject: [funds-cvs] r199 - trunk/funds/src
Message-ID: <20070820170957.8AD92640F9@common-lisp.net>
Author: abaine
Date: Mon Aug 20 13:09:57 2007
New Revision: 199
Modified:
trunk/funds/src/f-array.lisp
Log:
Documented f-array functions.
Modified: trunk/funds/src/f-array.lisp
==============================================================================
--- trunk/funds/src/f-array.lisp (original)
+++ trunk/funds/src/f-array.lisp Mon Aug 20 13:09:57 2007
@@ -34,17 +34,21 @@
(f array 0)))
(defun f-array-count (item f-array &key (key #'identity) (test #'eql))
+ "The number of elements in the given f-array that satisfy the test."
(tree-count item f-array
:key #'(lambda (tree)
(funcall key (bt-value tree)))
:test test))
(defun f-array-count-if (pred f-array &key (key #'identity))
+ "The number of elements in the given f-array that satisfy the test."
(tree-count-if pred f-array
:key #'(lambda (tree)
(funcall key (bt-value tree)))))
(defun map-f-array (function f-array)
+ "A new f-array whose elements are the results of the application
+of the given function to the elements of the given f-array."
(map-tree #'(lambda (tree)
(funcall function (bt-value tree)))
f-array))
From abaine at common-lisp.net Mon Aug 20 17:11:46 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 13:11:46 -0400 (EDT)
Subject: [funds-cvs] r200 - in trunk/funds: . tests
Message-ID: <20070820171146.51AC36F24B@common-lisp.net>
Author: abaine
Date: Mon Aug 20 13:11:46 2007
New Revision: 200
Removed:
trunk/funds/issues.txt
trunk/funds/tests/
Log:
Deleted tests and issues.
From abaine at common-lisp.net Mon Aug 20 17:54:19 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 13:54:19 -0400 (EDT)
Subject: [funds-cvs] r201 - trunk/funds
Message-ID: <20070820175419.2F4D3431B7@common-lisp.net>
Author: abaine
Date: Mon Aug 20 13:54:19 2007
New Revision: 201
Modified:
trunk/funds/README
Log:
Removed test instructions because there are no more tests.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Mon Aug 20 13:54:19 2007
@@ -16,21 +16,4 @@
> (asdf:operate 'asdf:load-op 'funds)
To see the publicly exported symbols in package "FUNDS," look at the
-file funds/src/package.lisp.
-
-RUNNING THE TESTS
-
-Funds' test suite uses lisp-unit, a unit test framework available from
-http://www.cs.northwestern.edu/academics/courses/325/programs/lisp-unit.lisp.
-Because lisp-unit is small and stable, it is included with funds.
-
-Make a symbolic link to funds/tests/funds-tests.asd somewhere visible
-to asdf. As above, this would be:
-
- prompt $ cd /somewhere/in/*central-registry*
- prompt $ ln -s /path/to/funds/tests/funds-tests.asd .
-
-Now type at a lisp prompt:
-
- > (asdf:operate 'asdf:load-op 'funds-tests)
- > (lisp-unit:run-all-tests :funds-tests)
+file funds/src/package.lisp.
From abaine at common-lisp.net Mon Aug 20 17:56:54 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 13:56:54 -0400 (EDT)
Subject: [funds-cvs] r202 - trunk/funds/src
Message-ID: <20070820175654.2E1B083049@common-lisp.net>
Author: abaine
Date: Mon Aug 20 13:56:51 2007
New Revision: 202
Modified:
trunk/funds/src/queue.lisp
Log:
Superficial.
Modified: trunk/funds/src/queue.lisp
==============================================================================
--- trunk/funds/src/queue.lisp (original)
+++ trunk/funds/src/queue.lisp Mon Aug 20 13:56:51 2007
@@ -67,7 +67,7 @@
"The elements in the given queue, returned as a list, in the order they
would be dequeued from the given queue."
(mapcar #'cdr (sort (tree-as-alist (queue-heap q))
- #'< :key #'car)))
+ #'< :key #'car)))
(defun queue-count (item q &key (key #'identity) (test #'eql))
"The number of elements in the given queue that satisfy the test."
From abaine at common-lisp.net Mon Aug 20 17:57:41 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 13:57:41 -0400 (EDT)
Subject: [funds-cvs] r203 - trunk/funds/src/heap
Message-ID: <20070820175741.4F11983049@common-lisp.net>
Author: abaine
Date: Mon Aug 20 13:57:41 2007
New Revision: 203
Modified:
trunk/funds/src/heap/heap.lisp
Log:
Added all-important stitch-tree specializing on heap.
Modified: trunk/funds/src/heap/heap.lisp
==============================================================================
--- trunk/funds/src/heap/heap.lisp (original)
+++ trunk/funds/src/heap/heap.lisp Mon Aug 20 13:57:41 2007
@@ -36,3 +36,10 @@
(defmethod tree-weight ((tree heap))
(heap-weight tree))
+
+(defmethod stitch-tree ((tree heap)
+ &key (key (bt-key tree)) (value (bt-value tree)) left right)
+ (make-heap :priority key
+ :value value
+ :left left
+ :right right))
From abaine at common-lisp.net Mon Aug 20 18:00:19 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:00:19 -0400 (EDT)
Subject: [funds-cvs] r204 - trunk/funds
Message-ID: <20070820180019.6313A830B2@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:00:19 2007
New Revision: 204
Modified:
trunk/funds/README
Log:
Added pointer to latest version.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Mon Aug 20 14:00:19 2007
@@ -1,6 +1,9 @@
INSTALLING FUNDS
+The latest version of funds is available at
+http://common-lisp.net/project/funds.
+
Funds is designed to be loaded with asdf, available from
http://cclan.cvs.sourceforge.net/*checkout*/cclan/asdf/asdf.lisp.
Make a symbolic link to the file funds/src/funds.asd somewhere visible
From abaine at common-lisp.net Mon Aug 20 18:01:18 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:01:18 -0400 (EDT)
Subject: [funds-cvs] r205 - trunk/funds/doc
Message-ID: <20070820180118.B9633830B2@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:01:17 2007
New Revision: 205
Removed:
trunk/funds/doc/
Log:
Deleted doc directory.
From abaine at common-lisp.net Mon Aug 20 18:04:09 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:04:09 -0400 (EDT)
Subject: [funds-cvs] r206 - in trunk/funds: examples src/examples
Message-ID: <20070820180409.6BF58830B2@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:04:09 2007
New Revision: 206
Added:
trunk/funds/examples/
- copied from r205, trunk/funds/src/examples/
Removed:
trunk/funds/src/examples/
Log:
Moved examples to top-level directory.
From abaine at common-lisp.net Mon Aug 20 18:06:05 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:06:05 -0400 (EDT)
Subject: [funds-cvs] r207 - trunk/funds
Message-ID: <20070820180605.0129F7208F@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:06:04 2007
New Revision: 207
Modified:
trunk/funds/README
Log:
Added instructions for the solver.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Mon Aug 20 14:06:04 2007
@@ -20,3 +20,9 @@
To see the publicly exported symbols in package "FUNDS," look at the
file funds/src/package.lisp.
+
+SEEING THE EXAMPLES
+
+Make a symbolic link to the file funds/examples/funds-examples.asd visible
+to asdf. Type (asdf:operate 'asdf:load-op 'funds-examples). Now try
+(solve p1) to see a functional sudoku solver at work.
\ No newline at end of file
From abaine at common-lisp.net Mon Aug 20 18:08:14 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:08:14 -0400 (EDT)
Subject: [funds-cvs] r208 - trunk/funds
Message-ID: <20070820180814.A699B111D2@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:08:14 2007
New Revision: 208
Modified:
trunk/funds/README
Log:
Superficial.
Modified: trunk/funds/README
==============================================================================
--- trunk/funds/README (original)
+++ trunk/funds/README Mon Aug 20 14:08:14 2007
@@ -25,4 +25,4 @@
Make a symbolic link to the file funds/examples/funds-examples.asd visible
to asdf. Type (asdf:operate 'asdf:load-op 'funds-examples). Now try
-(solve p1) to see a functional sudoku solver at work.
\ No newline at end of file
+(solve p1) to see a functional sudoku solver at work.
From abaine at common-lisp.net Mon Aug 20 18:30:58 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:30:58 -0400 (EDT)
Subject: [funds-cvs] r209 - trunk/public_html
Message-ID: <20070820183058.4FB49640F9@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:30:57 2007
New Revision: 209
Modified:
trunk/public_html/index.html
Log:
Updated homepage to include gsoc snapshot.
Modified: trunk/public_html/index.html
==============================================================================
--- trunk/public_html/index.html (original)
+++ trunk/public_html/index.html Mon Aug 20 14:30:57 2007
@@ -36,12 +36,12 @@
Download
- This project has not released any files. It is under active
- development as a Funds is under active development as a
- Google Summer of Code Project, and a release is planned for
- August 20, 2007. In the meantime, the sources are available from
- subversion repository.
+ Google Summer of Code Project. The current release is the google summer of
+code submission: funds-gsoc-snapshot.tar.gz
+. Further releases can be expected before the end of the summer. In the meantime,
+more recent sources are available from the subversion repository.
From abaine at common-lisp.net Mon Aug 20 18:34:52 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:34:52 -0400 (EDT)
Subject: [funds-cvs] r210 - public_html trunk/public_html
Message-ID: <20070820183452.E87D372091@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:34:51 2007
New Revision: 210
Added:
public_html/
- copied from r209, trunk/public_html/
Removed:
trunk/public_html/
Log:
Moved web-page to top-level of repository; there was no reason for it to be included in trunk.
From abaine at common-lisp.net Mon Aug 20 18:41:54 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 20 Aug 2007 14:41:54 -0400 (EDT)
Subject: [funds-cvs] r211 - tags/funds-gsoc-snapshot
Message-ID: <20070820184154.9A12B7A000@common-lisp.net>
Author: abaine
Date: Mon Aug 20 14:41:54 2007
New Revision: 211
Added:
tags/funds-gsoc-snapshot/
- copied from r210, trunk/funds/
Log:
Tagging the google summer of code release.
From abaine at common-lisp.net Tue Aug 21 12:32:48 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 21 Aug 2007 08:32:48 -0400 (EDT)
Subject: [funds-cvs] r212 - trunk/funds/examples
Message-ID: <20070821123248.B66194E04D@common-lisp.net>
Author: abaine
Date: Tue Aug 21 08:32:48 2007
New Revision: 212
Modified:
trunk/funds/examples/sudoku.lisp
Log:
Fixed solver (!) and made pretty printer.
Modified: trunk/funds/examples/sudoku.lisp
==============================================================================
--- trunk/funds/examples/sudoku.lisp (original)
+++ trunk/funds/examples/sudoku.lisp Tue Aug 21 08:32:48 2007
@@ -126,7 +126,7 @@
"")))))))))
(defun puzzle-solve (puzzle)
- (if (puzzle-complete-p puzzle)
+ (if (puzzle-solved-p puzzle)
puzzle
(iter (for f in x-y-z-functions)
(for (values x y n) = (best-group puzzle f))
@@ -209,3 +209,49 @@
#'i-k-j-coordinates
#'j-k-i-coordinates
#'b-k-x-coordinates))
+
+(defun print-sudoku (list)
+ (let* ((size (length list))
+ (order (order size)))
+ (labels ((f (result list i)
+ (if (null list)
+ result
+ (f (concatenate 'string result
+ (if (zerop (mod i order))
+ (filler-string size)
+ "")
+ (row-as-string (first list)))
+ (rest list)
+ (1+ i)))))
+ (concatenate 'string (f (format nil "~%") list 0)
+ (filler-string size)))))
+
+(defun row-as-string (row)
+ (let* ((size (length row))
+ (order (order size)))
+ (labels ((f (result list i)
+ (if (null list)
+ result
+ (f (concatenate 'string result
+ (if (zerop (mod i order))
+ "| "
+ "")
+ (format nil "~2A" (if (zerop (first list))
+ ""
+ (first list))))
+ (rest list)
+ (1+ i)))))
+ (concatenate 'string (format nil "~%") (f "" row 0) "|"))))
+
+(defun filler-string (size)
+ (let ((order (order size)))
+ (labels ((f (result i)
+ (if (= i size)
+ result
+ (f (concatenate 'string result
+ (if (zerop (mod i order))
+ "+-"
+ "")
+ "--")
+ (1+ i)))))
+ (concatenate 'string (format nil "~%") (f "" 0) "+"))))
From abaine at common-lisp.net Tue Aug 21 17:30:42 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Tue, 21 Aug 2007 13:30:42 -0400 (EDT)
Subject: [funds-cvs] r213 - trunk/funds/examples
Message-ID: <20070821173042.326EB3F01A@common-lisp.net>
Author: abaine
Date: Tue Aug 21 13:30:41 2007
New Revision: 213
Modified:
trunk/funds/examples/sudoku.lisp
Log:
Eliminated un-needed functions from solver.
Modified: trunk/funds/examples/sudoku.lisp
==============================================================================
--- trunk/funds/examples/sudoku.lisp (original)
+++ trunk/funds/examples/sudoku.lisp Tue Aug 21 13:30:41 2007
@@ -46,15 +46,10 @@
(round (expt (puzzle-size puzzle) 3))))
(defun puzzle-solved-p (puzzle)
- (= (round (expt (puzzle-size puzzle) 2))
- (tree-count +true+ (puzzle-tree puzzle) :key #'bt-value :test #'=)))
-
-(defun puzzle-solvable-p (puzzle)
(let ((size (puzzle-size puzzle)))
- (iter (for f in x-y-z-functions)
- (always (iter (for x below size)
- (always (iter (for y below size)
- (always (group-solvable puzzle f x y)))))))))
+ (= (round (expt size 2))
+ (tree-count +true+ (puzzle-tree
+ puzzle) :key #'bt-value :test #'=))))
(defun fill-true (puzzle i j k)
(fill-falses (set-to-true puzzle i j k) i j k))
@@ -190,21 +185,6 @@
(mod x order))
k)))
-(defun group-solved (puzzle x-y-z-function x y)
- (let ((size (puzzle-size puzzle)))
- (= 1 (iter (for z below size)
- (count (elt-true-p (multiple-value-call
- #'puzzle-elt puzzle
- (funcall x-y-z-function x y z size))))))))
-
-(defun group-solvable (puzzle x-y-z-function x y)
- (let ((size (puzzle-size puzzle)))
- (iter (for z below size)
- (for elt = (multiple-value-call #'puzzle-elt
- puzzle (funcall x-y-z-function x y z size)))
- (thereis (or (elt-unknown-p elt)
- (elt-true-p elt))))))
-
(defvar x-y-z-functions (list #'i-j-k-coordinates
#'i-k-j-coordinates
#'j-k-i-coordinates
From abaine at common-lisp.net Tue Aug 28 01:04:26 2007
From: abaine at common-lisp.net (abaine at common-lisp.net)
Date: Mon, 27 Aug 2007 21:04:26 -0400 (EDT)
Subject: [funds-cvs] r214 - trunk/funds/src
Message-ID: <20070828010426.B0FD31C0B9@common-lisp.net>
Author: abaine
Date: Mon Aug 27 21:04:23 2007
New Revision: 214
Modified:
trunk/funds/src/dictionary.lisp
Log:
Fixed faulty dictionary-from-alist.
Modified: trunk/funds/src/dictionary.lisp
==============================================================================
--- trunk/funds/src/dictionary.lisp (original)
+++ trunk/funds/src/dictionary.lisp Mon Aug 27 21:04:23 2007
@@ -57,8 +57,8 @@
(f (bt-right tree))))))
(f (dict-tree d))))
-(defun dictionary-from-alist (alist)
+(defun dictionary-from-alist (alist &key (test #'eql) (hash #'sxhash))
(reduce #'(lambda (d pair)
(dictionary-add d (car pair) (cdr pair)))
alist
- :initial-value (make-dictionary)))
\ No newline at end of file
+ :initial-value (make-dictionary :test test :hash hash)))
\ No newline at end of file