Commit ed1ae614 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Modifications to compile with MoCL.

parent f99a7da9
......@@ -635,13 +635,17 @@ RETURN: *character-sets*
(when (cs-lisp-encoding cs)
(let ((charset (find-symbol (first (cs-lisp-encoding cs)) "CHARSET")))
(setf (cs-ranges cs)
#+#.(cl:if (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#+#.(cl:if #+mocl (cl:and (cl:find-package "SYSTEM")
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-mocl (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
'(:and) '(:or))
(map 'vector (function char-code)
(system::get-charset-range charset))
#-#.(cl:if (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-#.(cl:if #+mocl (cl:and (cl:find-package "SYSTEM")
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-mocl (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
'(:and) '(:or))
(coerce
(loop
......
......@@ -152,7 +152,12 @@ NOTE: Parentheses inside the string must be escaped by \ unless balanced.
(escape (vector-push-extend ch buffer) (setf escape nil))
((char= #\( ch) (vector-push-extend ch buffer) (incf level))
((char= #\) ch) (decf level) (if (minusp level)
(loop-finish)
#-mocl (loop-finish)
#+moc (if ch
(return buffer)
(if eof-error-p
(error 'end-of-file :stream stream)
(return eof-value)))
(vector-push-extend ch buffer)))
((char= #\\ ch) (setf escape t))
(t (vector-push-extend ch buffer)))
......
......@@ -59,9 +59,10 @@
"com.informatimago.lispdoc"
"com.informatimago.small-cl-pgms"
"com.informatimago.future"
"com.informatimago.objcl" ; empty shell on non-ccl darwin
"com.informatimago.susv3" ; empty shell on non-clisp.
"com.informatimago.clisp" ; empty shell on non-clisp linux
"com.informatimago.editor" ; future
"com.informatimago.objcl" ; empty shell on non-ccl darwin
"com.informatimago.susv3" ; empty shell on non-clisp.
"com.informatimago.clisp" ; empty shell on non-clisp linux
)
:components ()
:in-order-to ((asdf:test-op (asdf:test-op "com.informatimago.test"))))
......
......@@ -66,9 +66,10 @@
"com.informatimago.lispdoc.test"
"com.informatimago.small-cl-pgms.test"
"com.informatimago.future.test"
"com.informatimago.objcl.test" ; empty shell on non-ccl darwin
"com.informatimago.susv3.test" ; empty shell on non-clisp.
"com.informatimago.clisp.test" ; empty shell on non-clisp linux
"com.informatimago.editor.test" ; future
"com.informatimago.objcl.test" ; empty shell on non-ccl darwin
"com.informatimago.susv3.test" ; empty shell on non-clisp.
"com.informatimago.clisp.test" ; empty shell on non-clisp linux
)
:components ()
:in-order-to ((asdf:test-op
......@@ -81,6 +82,7 @@
(asdf:test-op "com.informatimago.lispdoc.test")
(asdf:test-op "com.informatimago.small-cl-pgms.test")
(asdf:test-op "com.informatimago.future.test")
(asdf:test-op "com.informatimago.editor.test")
(asdf:test-op "com.informatimago.objcl.test")
(asdf:test-op "com.informatimago.susv3.test")
(asdf:test-op "com.informatimago.clisp.test"))))
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: activity-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Test activity.lisp.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-03-01 <PJB> Extracted from activity.lisp.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ACTIVITY.TEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ACTIVITY")
(:export "TEST/ALL" "INTERACTIVE-TEST"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ACTIVITY.TEST")
(define-condition debugger-invocation (condition)
((format-control :accessor debugger-invocation-format-control
:initarg :format-control
:initform "Debugger invocation"
:type string)
(format-arguments :accessor debugger-invocation-format-arguments
:initarg :format-arguments
:initform '()
:type list))
(:documentation
"SBCL expects for INVOKE-DEBUGGER, objects of type CL:CONDITION,
not mere 'condition' objects.")
(:report (lambda (condition stream)
(apply (function format) stream
(debugger-invocation-format-control condition)
(debugger-invocation-format-arguments condition)))))
(defun cdebugger (&optional (reason "User request"))
(restart-case
(invoke-debugger (make-condition 'debugger-invocation
:format-control "~A"
:forma-arguments (list reason)))
(continue ()
:report "Continue"
(return-from cdebugger))))
(defmacro define-menu (name title &rest items)
`(defun ,name ()
(loop
(flet ((exit-menu-loop (&optional result)
(return-from ,name result)))
(block try-again
(format *query-io* "~2%Menu ~A~2%" ,title)
(format *query-io* "~:{ ~A) ~A~%~}" ',items)
(format *query-io* "~%Your choice: ")
(let ((choice (string-trim " " (read-line *query-io*))))
(format *query-io* "~%")
(case (or (and (string= "" choice)
(let ((item (find :default ',items
:key (function fourth))))
(if item
(first item)
(progn
(format *query-io* "~%Invalid choice~%")
(return-from try-again)))))
(aref choice 0))
,@(mapcar (lambda (item) `((,(first item)) ,(third item))) items)
(otherwise (format *query-io* "~%Invalid choice~%") ))))))))
(define-menu act-created-menu
"Activity Created"
(#\g "Go on" (exit-menu-loop) :default)
(#\d "Invoke the debugger" (block debugger
(restart-case
(invoke-debugger
(make-condition 'debugger-invocation
:format-control "User request"))
(menu ()
:report "Back to the menu"
(return-from debugger))
(goon ()
:report "Go on"
(exit-menu-loop)))))
(#\p "Print activities" (print-scheduler-activities *scheduler*)))
(defun interactive-test (&key debug)
(let ((start (get-universal-time)))
(macrolet
((run (&body body)
`(lambda ()
(formatalot "~12D :name ~30S :period ~3D~%"
(- (get-universal-time) start)
(activity-name (current-activity))
(activity-period (current-activity)))
,@body))
(mkact (&rest args)
`(progn
(when debug
(formatalot "Before creating a new ")
(print-scheduler-activities *scheduler*)
(formatalot "Let's create the new activity."))
(prog1 (make-activity ,@args)
(when debug
(print-scheduler-activities *scheduler*)
(act-created-menu))))))
(format t "~%")
(mkact (run (return-from test))
:name "stopper"
:start-in 60)
(mkact (run
;; (cdebugger "Check increment period...")
(incf (activity-period (current-activity))))
:name "period increasing from 0"
:period 0)
(mkact (let ((times 11))
(run
(let ((act (current-activity)))
(case (decf times)
((10)
(setf (activity-period act) 30))
((9)
(setf (activity-period act) 2)
(setf (activity-scheduled-time act)
(+ (get-time act) 2)))
((0)
(destroy-activity act))))))
:name "period 2 between 30 and 50"
:period 30)
(mkact (run)
:name "period 10"
:period 10)
(mkact (run)
:name "period 7"
:period 7)
(mkact (run)
:name "period 5"
:period 5)
(mkact (run)
:name "period 5'"
:period 5)
(let ((activity (mkact (run)
:name "period 5\", to be destroyed in 15s"
:period 5)))
(mkact (run (if (activity-scheduler activity)
(destroy-activity activity)
(destroy-activity (current-activity))))
:name "Destroyer of [period 5\", to be destroyed in 15s]"
:start-in 15)))
(print-scheduler-activities *scheduler*)
(activity-run)
(values)))
(define-test test/all ()
)
;;;; THE END ;;;;
This diff is collapsed.
......@@ -91,14 +91,20 @@ License:
#+mocl
(setf *features* (append '(:newline-is-linefeed :has-ascii-code
:has-vt :has-bell :has-escape :has-linefeed
:has-return :has-backspace :has-tab
:has-page :has-rubout) *features*))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *standard-characters*
#.(concatenate 'string
" !\"#$%&'()*+,-./0123456789:;<=>?"
"@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
"`abcdefghijklmnopqrstuvwxyz{|}~")
" !\"#$%&'()*+,-./0123456789:;<=>?"
"@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
"`abcdefghijklmnopqrstuvwxyz{|}~")
"A string containing all the STANDARD-CHARACTER.
Notice: it's the same character set as
COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ASCII:*ASCII-CHARACTERS*.")
......@@ -144,11 +150,12 @@ DO: If the implementation has the semi standard character
"
(when (has-character-named-p name)
(pushnew (intern (format nil "~:@(HAS-~A~)" name)
(load-time-value (find-package"KEYWORD")))
*features*)))
(pushnew (intern (format nil "~:@(HAS-~A~)" name)
(load-time-value (find-package"KEYWORD")))
*features*)))
#-mocl
(dolist (name '("Rubout" "Page" "Tab" "Backspace" "Return" "Linefeed"
;; Non standard character names:
"Escape" "Bell" "Vt"))
......@@ -157,6 +164,8 @@ DO: If the implementation has the semi standard character
);;eval-when
;; Must be a separate form:
(eval-when (:compile-toplevel :load-toplevel :execute)
......@@ -185,15 +194,17 @@ DO: If the implementation has the semi standard character
#+has-escape (= 27 (char-code #\escape))
#+has-bell (= 7 (char-code #\bell))
#+has-vt (= 11 (char-code #\vt)))))
#-mocl
(progn
(when (has-ascii-code-p)
(pushnew :has-ascii-code *features*))
#+has-return (when (char= #\newline #\return)
(pushnew :newline-is-return *features*))
#+has-linefeed (when (char= #\newline #\linefeed)
(pushnew :newline-is-linefeed *features*)))
(when (has-ascii-code-p)
(pushnew :has-ascii-code *features*))
#+has-return (when (char= #\newline #\return)
(pushnew :newline-is-return *features*))
#+has-linefeed (when (char= #\newline #\linefeed)
(pushnew :newline-is-linefeed *features*))
);;eval-when
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: combination-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Tests combination.lisp.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-02-28 <PJB> Extracted from combination.lisp.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.COMBINATION.TEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.COMBINATION")
(:export "TEST/ALL"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.COMBINATION.TEST")
(define-test test/arrangement-with-repeat/take-3-of-5 ()
(let ((awr (make-instance 'arrangement-with-repeat)))
(setf (base-cardinal awr) 5
(element-size awr) 3)
(reset awr)
(assert-true (= 125 (cardinal awr)))
(assert-true (equalp (loop :named awr
:with results = '()
:do (multiple-value-bind (arrangement done) (get-next-element awr)
(when done (return-from awr (nreverse results)))
(push arrangement results)))
'(#(0 0 0) #(0 0 1) #(0 0 2) #(0 0 3) #(0 0 4) #(0 1 0) #(0 1 1)
#(0 1 2) #(0 1 3) #(0 1 4) #(0 2 0) #(0 2 1) #(0 2 2) #(0 2 3)
#(0 2 4) #(0 3 0) #(0 3 1) #(0 3 2) #(0 3 3) #(0 3 4) #(0 4 0)
#(0 4 1) #(0 4 2) #(0 4 3) #(0 4 4) #(1 0 0) #(1 0 1) #(1 0 2)
#(1 0 3) #(1 0 4) #(1 1 0) #(1 1 1) #(1 1 2) #(1 1 3) #(1 1 4)
#(1 2 0) #(1 2 1) #(1 2 2) #(1 2 3) #(1 2 4) #(1 3 0) #(1 3 1)
#(1 3 2) #(1 3 3) #(1 3 4) #(1 4 0) #(1 4 1) #(1 4 2) #(1 4 3)
#(1 4 4) #(2 0 0) #(2 0 1) #(2 0 2) #(2 0 3) #(2 0 4) #(2 1 0)
#(2 1 1) #(2 1 2) #(2 1 3) #(2 1 4) #(2 2 0) #(2 2 1) #(2 2 2)
#(2 2 3) #(2 2 4) #(2 3 0) #(2 3 1) #(2 3 2) #(2 3 3) #(2 3 4)
#(2 4 0) #(2 4 1) #(2 4 2) #(2 4 3) #(2 4 4) #(3 0 0) #(3 0 1)
#(3 0 2) #(3 0 3) #(3 0 4) #(3 1 0) #(3 1 1) #(3 1 2) #(3 1 3)
#(3 1 4) #(3 2 0) #(3 2 1) #(3 2 2) #(3 2 3) #(3 2 4) #(3 3 0)
#(3 3 1) #(3 3 2) #(3 3 3) #(3 3 4) #(3 4 0) #(3 4 1) #(3 4 2)
#(3 4 3) #(3 4 4) #(4 0 0) #(4 0 1) #(4 0 2) #(4 0 3) #(4 0 4)
#(4 1 0) #(4 1 1) #(4 1 2) #(4 1 3) #(4 1 4) #(4 2 0) #(4 2 1)
#(4 2 2) #(4 2 3) #(4 2 4) #(4 3 0) #(4 3 1) #(4 3 2) #(4 3 3)
#(4 3 4) #(4 4 0) #(4 4 1) #(4 4 2) #(4 4 3) #(4 4 4))))))
(define-test test/arrangement-sans-repeat/take-3-of-5-distinct ()
(let ((asr (make-instance 'arrangement-sans-repeat)))
(setf (base-cardinal asr) 5
(element-size asr) 3)
(reset asr)
(assert-true (= 60 (cardinal asr)))
(assert-true (equalp (loop :with results = '()
:named asr
:do (multiple-value-bind (arrangement done) (get-next-element asr)
(when done (return-from asr (nreverse results)))
(push arrangement results)))
'(#(0 1 2) #(0 1 3) #(0 1 4) #(0 2 1) #(0 2 3) #(0 2 4) #(0 3 1)
#(0 3 2) #(0 3 4) #(0 4 1) #(0 4 2) #(0 4 3) #(1 0 2) #(1 0 3)
#(1 0 4) #(1 2 0) #(1 2 3) #(1 2 4) #(1 3 0) #(1 3 2) #(1 3 4)
#(1 4 0) #(1 4 2) #(1 4 3) #(2 0 1) #(2 0 3) #(2 0 4) #(2 1 0)
#(2 1 3) #(2 1 4) #(2 3 0) #(2 3 1) #(2 3 4) #(2 4 0) #(2 4 1)
#(2 4 3) #(3 0 1) #(3 0 2) #(3 0 4) #(3 1 0) #(3 1 2) #(3 1 4)
#(3 2 0) #(3 2 1) #(3 2 4) #(3 4 0) #(3 4 1) #(3 4 2) #(4 0 1)
#(4 0 2) #(4 0 3) #(4 1 0) #(4 1 2) #(4 1 3) #(4 2 0) #(4 2 1)
#(4 2 3) #(4 3 0) #(4 3 1) #(4 3 2))))))
(define-test test/combination/3-from-5 ()
(let ((com (make-instance 'combination)))
(setf (base-cardinal com) 5
(element-size com) 3)
(reset com)
(assert-true (= 10 (cardinal com)))
(assert-true (equalp (loop :with results = '()
:named com
:do (multiple-value-bind (arrangement done) (get-next-element com)
(when done (return-from com (nreverse results)))
(push arrangement results)))
'(#(0 1 2) #(0 1 3) #(0 1 4) #(0 2 3) #(0 2 4) #(0 3 4) #(1 2 3)
#(1 2 4) #(1 3 4) #(2 3 4))))))
(define-test test/all ()
(test/arrangement-with-repeat/take-3-of-5)
(test/arrangement-sans-repeat/take-3-of-5-distinct)
(test/combination/3-from-5))
;;;; THE END ;;;;
......@@ -32,7 +32,6 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>
;;;;****************************************************************************
(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.COMBINATION"
(:use "COMMON-LISP")
(:export "DONE-P" "GET-NEXT-ELEMENT" "GET-CURRENT-ELEMENT" "RESET"
......@@ -204,7 +203,7 @@ RETURN: !atBegining()
:documentation "The cardinal of the functor set.")
(index :type cardinal :initform 0 :reader index)
(element-size :type cardinal :initform 0 :reader element-size)
(choice :type vector :initform nil)
(choice :type vector :initform #())
(at-beginning-p :type boolean :initform nil :reader at-beginning-p))
(:documentation "Representation of an enumerable set."))
......@@ -461,43 +460,4 @@ RETURN: a list of all the combinations of N elements from the LIST.
(combinations (rest list) (1- n)))
(combinations (rest list) n)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test ()
(terpri)(terpri)
(let ((awr (make-instance 'arrangement-with-repeat)))
(setf (base-cardinal awr) 5
(element-size awr) 3)
(reset awr)
(princ "Take 3 of 5. ")
(princ (cardinal awr))
(loop named awr do
(multiple-value-bind (arrangement done) (get-next-element awr)
(when done (loop-finish))
(print arrangement)))
(terpri))
(let ((asr (make-instance 'arrangement-sans-repeat)))
(setf (base-cardinal asr) 5
(element-size asr) 3)
(reset asr)
(princ "Take 3 of 5 distinct. ")
(princ (cardinal asr))
(loop named asr do
(multiple-value-bind (arrangement done) (get-next-element asr)
(when done (loop-finish))
(print arrangement)))
(terpri))
(let ((com (make-instance 'combination)))
(setf (base-cardinal com) 5
(element-size com) 3)
(reset com)
(princ "Combination of 3 from 5. ")
(princ (cardinal com))
(loop named com do
(multiple-value-bind (arrangement done) (get-next-element com)
(when done (loop-finish))
(print arrangement)))
(terpri)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: constraints-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Tests constraints.lisp.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-02-28 <PJB> Extracted from constraints.lisp.
;;;;BUGS
;;;;
;;;; - test not implemented yet.
;;;;
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS")
(:export "TEST/ALL"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS")
(defparameter *germany*
(make-graph (mapcan (lambda (edge) (list edge (reverse edge)))
'((frankfurt mannheim)
(frankfurt wuerzburg)
(frankfurt kassel)
(stuttgart nuemberg)
(mannheim karlsruhe)
(wuerzburg erfurt)
(wuerzburg nuemberg)
(kassel muenchen)
(karlsruhe augsburg)
(augsburg muenchen)
(nuemberg muenchen)))))
(define-test test/all ()
)
;;;; THE END ;;;;
......@@ -55,7 +55,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2011 - 2012
Copyright Pascal J. Bourguignon 2011 - 2015
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
......@@ -103,24 +103,6 @@ License:
(dictionary-get graph node))
(defparameter *germany*
(make-graph (mapcan (lambda (edge) (list edge (reverse edge)))
'((frankfurt mannheim)
(frankfurt wuerzburg)
(frankfurt kassel)
(stuttgart nuemberg)
(mannheim karlsruhe)
(wuerzburg erfurt)
(wuerzburg nuemberg)
(kassel muenchen)
(karlsruhe augsburg)
(augsburg muenchen)
(nuemberg muenchen)))))
(defun breadth-first-search (graph root goal &key (test 'eql) key)
"
DO: Implement the Breadth First Search algorithm on the given
......
......@@ -338,17 +338,16 @@ License:
(progn
(setf current (copy-range (aref b j)))
(incf j)))
(loop-finish)))
:finally (progn
(loop
:while (< i lena)
:do (progn (vector-push-extend (copy-range (aref a i)) result (length result))
(incf i)))
(loop
:while (< j lenb)
:do (progn (vector-push-extend (copy-range (aref b j)) result (length result))
(incf j)))
(return result))))))
(progn
(loop
:while (< i lena)
:do (progn (vector-push-extend (copy-range (aref a i)) result (length result))
(incf i)))
(loop
:while (< j lenb)
:do (progn (vector-push-extend (copy-range (aref b j)) result (length result))
(incf j)))
(return result))))))))
(defun intersect-ranges (a b)
......@@ -370,7 +369,7 @@ License:
:do (progn
(incf i)
(setf current-a (when (< i lena) (aref a i)))))
(unless current-a (loop-finish))
(unless current-a (return result))
(loop
:while (and (< j lenb)
......@@ -378,7 +377,7 @@ License:
:do (progn
(incf j)
(setf current-b (when (< j lenb) (aref b j)))))
(unless current-b (loop-finish))
(unless current-b (return result))
(unless (or (<= (range-end current-a) (range-start current-b))
(<= (range-end current-b) (range-start current-a)))
......@@ -392,22 +391,21 @@ License:
(incf i)
(if (< i lena)
(setf current-a (aref a i))
(loop-finish))
(return result))
(incf j)
(if (< j lenb)
(setf current-b (aref b j))
(loop-finish)))
(return result)))
((< (range-end current-a) (range-end current-b))
(incf i)
(if (< i lena)
(setf current-a (aref a i))
(loop-finish)))
(return result)))
(t
(incf j)
(if (< j lenb)
(setf current-b (aref b j))
(loop-finish))))))
:finally (return result)))))
(return result))))))))))
(defun difference-ranges (r1 r2)
......
......@@ -63,7 +63,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2004 - 2012
Copyright Pascal J. Bourguignon 2004 - 2015