Implement utility functions for dependency solving

Also, add legal stuff.

diff --git a/src/thales/solver.scm b/src/thales/solver.scm
index 4905bfde4929c7fe0b49b0a4cb092e3c2d3e2c7a..1e929e373c66204a1e6dcf67c24dd574a219fa9d 100644 (file)
--- a/src/thales/solver.scm
+++ b/src/thales/solver.scm
@@ -1,4 +1,23 @@
-;;; Thales solver --- implementation of core idea
+;;; solver.scm --- Thales solver --- implementation of core idea
+
+;; Copyright (C) 2013 Dmitry Bogatov <KAction@gnu.org>
+
+;; Author: Dmitry Bogatov <KAction@gnu.org>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License
+;; as published by the Free Software Foundation; either version 3
+;; of the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
 
 ;;; Core idea of Thales is packages manager, that eliminates dependencies
 ;;; hell. In generic case --- when every package version can depend
@@ -18,6 +37,87 @@
 ;;; wants to screw things, he will be able to.
 
 ;;; Currently, I have no idea how control compability of macroses.
+;; Code:
+(define-module (thales solver)
+    :export (perform-solve generate-r1-contrain-solver))
+(use-modules (ice-9 match))
+(use-modules (srfi srfi-1))
+(use-modules (thales seal))
+(use-modules (srfi srfi-26))
+
+(sealed version-compatible?
+       (& '(1 2) '(1 2 0) => #t)
+       (& '(1 2 3) '(1 2 2) => #f))
+
+(sealed satisfy
+       (& '(foo ? (1 0))
+          '(foo (1 0 0))
+          => #t)
+       (& '(foo ? (2 0))
+          '(foo (1 2 3))
+          => #f)
+       (& '(foo ? (1))
+          '(foo (1 2 3))
+          => #t)
+       (& '(foo ? (1 0) (2 0))
+          '(foo   (1 2 3))
+          => #t)
+       (& '(foo = (1 2 3))
+          '(foo   (1 2 3))
+          => #t)
+       (& '(foo = (1 2 4) (1 2 7))
+          '(foo   (1 2 5))
+          => #f))
+
+
+
+(define (version-compatible? v1 v2)
+    (if (equal? (car v1) (car v2))
+       (let version<= ((v1 (cdr v1)) (v2 (cdr v2)))
+           (match v1
+               [(x v1-rest ...)
+                (match v2
+                    ['() #f]
+                    [(y v2-rest ...)
+                     (cond [(< x y) #t]
+                           [(> x y) #f]
+                           [#t (version<= v1-rest v2-rest)])])]
+               ['() #t]))
+       #f))
+
+(define (version-equal? v1 v2)
+    (unless (and (list? v1) (list? v2))
+       (error "Invalid versions: ~a ~a" v1 v2))
+    (equal? v1 v2))
+
+
+(define (satisfy constr package)
+    (match package
+       ([pkgname pkg-version _ ...]
+        (match constr
+            ([?pkgname *cmp* versions ...]
+             (let ((cmp (case *cmp*
+                            [(?) version-compatible?]
+                            [(=) version-equal? ])))
+                 (and (eq? pkgname ?pkgname)
+                      (any #[cmp <> pkg-version] versions))))))))
+
+(define* (generate-r1-contrain-solver installed availible
+                                     #:key (conservative #f))
+    "Return function, that will packages, that satisfy constrain.
+
+Function, given constrain, return list of packages, that satistfy it,
+taking only one version from each major version. Order of packages influenced
+by list of INSTALLED packages, if CONSERVATIVE is #f.
+"
+    (let* ((cache (make-hash-table))
+          (cache-get #[hash-ref  cache <>])
+          (cache-put #[hash-set! cache <> <>]))
+       (lambda (constr)
+           (or (cache-get constr)
+               (let ((result (filter #[satisfy constr <>] availible)))
+                   (cache-put constr result)
+                   result)))))
 
 (define* (perform-solve installed availible constrains
                        #:key (conservative #f))
@@ -30,12 +130,13 @@ CONSTRAINS is list of constrains, that have following kinds:
 
     * Ridid request for specified package. To be used, if bug happens
       and dependency have to be resolved manually.
-        (<pkg-name> = (<major> <minor> <micro>))
+        (<pkg-name> = (<major> <minor> <micro>) ...)
     * Request for package version, no less that specified.
         (<pkg-name> ? (<major> <minor>) ... )
 
 Both INSTALLED and AVAILIBLE are lists of package in form
     (<pkg-name> (<major> <minor> <micro>) <constrains>)
 where <constrains> are never rigid."
+
 #f
 )