CLISP Version: 2.49
Leaf Node
(value (NIL) (NIL))
Non-Leaf Node
(value (value (NIL) (NIL)) (NIL))
Code ("format" for debug only)
; (nil) means NULL
(defun binary-insert (root obj <)
(if (null (cdr root))
(progn
(format t "In Null [~A] => " root)
(setf (car root) obj)
(format t "mid [~A] => " root)
(setf (cdr root) '((nil) (nil)))
(format t "[~A]~%" root))
(if (funcall < obj (car root))
(progn
(format t "In Left [~A] => " root)
(binary-insert (nth 1 root) obj <)
(format t "[~A]~%" root)) ; Left
(progn
(format t "In Right [~A] => " root)
(binary-insert (nth 2 root) obj <)
(format t "[~A]~%" root)) ; Right
)
)
)
Test
[1]> (load "binary_tree.lisp")
;; Loading file binary_tree.lisp ...
;; Loaded file binary_tree.lisp
T
[2]> (setf *glb-rt* '(NIL))
(NIL)
[3]> (binary-insert *glb-rt* 10 #'<)
In Null [(NIL)] => mid [(10)] => [(10 (NIL) (NIL))]
NIL
[4]> *glb-rt*
(10 (NIL) (NIL))
[5]> (binary-insert *glb-rt* 5 #'<)
In Left [(10 (NIL) (NIL))] => In Null [(NIL)] => mid [(5)] => [
*** - Lisp stack overflow. RESET
It seems the program died after executing
(setf (cdr root) '((NIL) (NIL)))
Thanks....
[Update]
Before (setf (cdr root) '((NIL) (NIL))), the "root" is (5)
Another test
[6]> (setf glb-ls '(5))
(5)
[7]> (setf (cdr glb-ls) '((NIL) (NIL)))
((NIL) (NIL))
[8]> glb-ls
(5 (NIL) (NIL))
This question has been answered in the CLISP FAQ How do I avoid stack overflow?
In your case the very first suggestion works: after
(setq *print-circle* t)
we get
In Left [(10 (NIL) (NIL))] => In Null [(NIL)] => mid [(5)] => [#1=(5 #1# (NIL))]
i.e., you are mistakenly creating a circular structure.
PS. You now owe me 10 zorkmids :-)
Related
I'm encountering a worrying error in SBCL -- I suspect that it arises from pilot error, and would love some tips if you have them!
Here is the error:
Memory fault at 0x52 (pc=0x52cffa19 [code 0x52cff6d0+0x349 ID 0x86a2], fp=0x7ff37f29f6d0, sp=0x7ff37f29f698) tid 0x7ff38ca82180
The integrity of this image is possibly compromised.
Continuing with fingers crossed.
"derp"
debugger invoked on a SB-SYS:MEMORY-FAULT-ERROR in thread
#<THREAD "main thread" RUNNING {1000510083}>:
Unhandled memory fault at #x52.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [ABORT] Exit debugger, returning to top level.
(HMAKER-II)
source: (LIST (CAR (CDR (CDR IENTRY))))
Here is the code that I'm running. It is a few connected subroutines in a larger program. The overall program takes structured text input and adds to a hash table, this subroutine takes the contents of the table and is intended to organize it back into a single structured output in the same form as the input (it's not quite finished, I've only got as far as creating a new table with modified data in order to create a well-formed output).
I'm conscious that my code is messy and can be improved -- I would appreciate pointers on improving it, but my main goal is first to fix the error before focusing in better and more efficient code.
Here you go:
(defun hmaker-launcher ()
(setf table-entries-for-hmaker (alexandria:hash-table-alist etable))
(hmaker))
(defun hmaker ()
(if (equal table-entries-for-hmaker nil)
(progn
(setf sorted-list-of-ientries (sort (alexandria:hash-table-alist itable) #'> :key #'third))
(hmaker-II)))
(setf table-entry-for-hmaker (car table-entries-for-hmaker))
(setf entry-name-for-hmaker (car table-entry-for-hmaker))
(setf entry-number (car (reverse table-entry-for-hmaker)))
(setf processed-entry-for-hmaker (cdr (reverse (cdr (cdr (reverse table-entry-for-hmaker))))))
(if (equal entry-number 8)
(progn
(setf (gethash entry-name-for-hmaker itable) (list '8 (length (car processed-entry-for-hmaker)) processed-entry-for-hmaker))
)
)
(if (equal entry-number 9)
(progn
(setf number-of-elements (list-length processed-entry-for-hmaker))
(setf (gethash entry-name-for-hmaker itable) (list '9 number-of-elements processed-entry-for-hmaker))
))
(setf table-entries-for-hmaker (cdr table-entries-for-hmaker))
(hmaker)
)
(defun hmaker-II ()
(if (equal sorted-list-of-ientries nil)
(inputter))
(setf ientry (car sorted-list-of-ientries))
(if (equal '9 (car (cdr ientry)))
(progn
(setf complexity-atom (list (car (cdr (cdr ientry)))))
(setf hmaker-complexity-list (append hmaker-complexity-list complexity-atom))
(setf (nth hmaker-recursion-counter complexity-adder) (+ (car (cdr (cdr identry))) (nth hmaker-recursion-counter complexity-adder)))
(setf (second (gethash (car ientry) itable)) complexity-adder)
(setf rel-parts (cdr (cdr (cdr ientry))))
(push "padding" rel-parts)
(hmaker-III rel-parts)
)
(defun hmaker-III (parts)
(setf parts (cdr parts))
(if (equal parts nil)
(setf sorted-list-of-ientries (cdr sorted-list-of-ientries))
(hmaker-II)
)
(setf part-in-question (car parts))
(if (equal '9 (car (cdr (part-in-question))))
(progn
(setf hmaker-recursion-counter (+ hmaker-recursion-counter 1))
(setf (nth hmaker-recursion-counter complexity-adder) (+ (car (cdr (gethash part-in-question)) (nth hmaker-recursion-counter complexity-adder))))
(setf sub-parts (cdr (cdr (gethash part-in-question itable))))
(hmaker-III sub-parts)
)
(progn
(hmaker-III parts))
)
)
Thoughts?
I am trying to make a 'pseudo OO system':
(defun bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
(defparameter bank-account-object (bank-account))
(funcall (funcall bank-account-object 'init) 42)
(funcall (funcall bank-account-object 'increment) 10)
(funcall (funcall bank-account-object 'get-balance))
Q: are there better ways to accomplish the same without using CLOS, defstruct, or defmacro?
The problem that I see with this is that it is closed for extension, and I see no simple way to add extensibility.
Minor nitpick: that's not a bank-system but a bank-account. When you think about that further, it seems to me that the interesting part about this example domain has not been touched: double accounting, i. e. ensuring the null-sum invariant.
There are two sayings: a closure is a poor man's object, and an object is a poor man's closure. I have the feeling that you are more in the realm of the former here. However, it might be a good learning experience to think about this—as long as you don't put it into production somewhere…
;; The "class"
(defun create-bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
;; The "methods"
(defun init-balance (object amount)
(funcall (funcall object 'init) amount))
(defun increment-balance (object amount)
(funcall (funcall object 'increment) amount))
(defun get-balance (object)
(funcall (funcall object 'get-balance)))
;; Example usage
(defparameter bank-account (create-bank-account))
(init-balance bank-account 42) ; => 42
(increment-balance bank-account 10) ; => 52
(get-balance bank-account) ; => 52
As mentioned in other answers, the resulting object might be hard to extend. That could be a feature, but one possible way to improve on it is to let it be redefined dynamically. You can even switch from classes to protoypes.
(ql:quickload :optima)
(defpackage :obj (:use :cl :optima))
(in-package :obj)
(defun make-object (&optional prototype)
(let ((properties (make-hash-table :test #'eq))
(self))
(flet ((resolve (key)
(or (gethash key properties)
(and prototype (funcall prototype :get key)))))
(setf self
(lambda (&rest args)
(optima:ematch args
((list :get :prototype) prototype)
((list :get key) (resolve key))
((list :set :prototype p)
(cerror "Continue" "Changing prototype object, are you sure?")
(setf prototype p))
((list :set key value)
(if value
(setf (gethash key properties) value)
(remhash key properties)))
((list :invoke method args)
(let ((resolved (resolve method)))
(if resolved
(apply resolved self args)
(funcall (or (resolve :no-such-method)
(error "No such method: ~a in ~a"
method
self))
self
method))))))))))
Some helper symbols:
;; call built-in command
(defmacro $ (obj method &rest args)
`(funcall ,obj ,method ,#args))
;; access property
(declaim (inline # (setf #)))
(defun # (o k) ($ o :get k))
(defun (setf #) (v o k) ($ o :set k v))
;; invoke method
(defun % (o m &rest a)
($ o :invoke m a))
A simple test
(let ((a (make-object)))
;; set name property
(setf (# a :name) "a")
;; inherit
(let ((b (make-object a)))
(print (list (# b :name)
;; shadow name property
(setf (# b :name) "b")
(# a :name)))
;; define a method
(setf (# a :foo) (lambda (self) (print "FOO")))
;; invoke it
(% a :foo)))
Bank account
(defun create-bank-account (&optional parent)
(let ((account (make-object parent)))
(prog1 account
(setf (# account :init)
(lambda (self x)
(setf (# self :balance) x)))
(setf (# account :increment)
(lambda (self increment)
(incf (# self :balance) increment))))))
(let ((account (create-bank-account)))
(% account :init 0)
(% account :increment 100)
(# account :balance))
100
I have the menu which is created in the options function and the functionality of that is to have the user input a number (1 or 2 or 3) in order to solve the problem with the chosen method (DFS, BFS, BESTFS). This method is supposed to return what the user selected in this line of code
(SearchProblem '(0 0 2 6 4) '(0 0 0 0 0) (Options)) in the end. The problem is that when I compile the problem it displays this error "Undefined function DFS called with arguments ().". How can I fix that?
Code
; ----------------------------------------------------------------------------
; ******** Search Code for DFS and other search methods
; ******** (expanding front and extending queue)
; ******** author: AI lab
; ********
; ******** Κώδικας για DFS και άλλες μεθόδους αναζήτησης
; ******** (επέκταση μετώπου και διαχείριση ουράς)
; ******** Συγγραφέας: Εργαστήριο ΤΝ
; ----------------------------------------------------------------------------
; **** starting search
; **** έναρξη αναζήτησης
(defun searchProblem (start-state goal method )
( cond
((StateValidation start-state)(print "Invalid data!") nil)
( T (findSolution (MakeFront start-state) (MakeQueue start-state) () goal method ) )
)
;(print '____BEGIN_SEARCHING_____ )
)
; **** Checking for valid states
(defun StateValidation (state)
(cond
( (or (> (first state) 3) (<(first state) 0)) t)
(T nil)
)
)
; ----------------------------------------------------------------------------
; **** Basic recursive function to create search tree (recursive tree expantion)
; **** Βασική αναδρομική συνάρτηση για δημιουργία δέντρου αναζήτησης (αναδρομική επέκταση δέντρου)
(defun FindSolution (front queue closed goal method )
(cond
((null front) 'no_solution)
((mymember (car front) closed) (FindSolution (cdr front) (cdr queue) closed goal method ))
((equal (car front) goal) (format T "This is the solution: ~a" (reverse (first queue))))
(T (FindSolution (ExpandFront front method) (ExtendQueue queue method) (cons (car front) closed) goal method ))
)
)
; ----------------------------------------------------------------------------
; **** FRONT
; **** Διαχείριση Μετώπου
; ----------------------------------------------------------------------------
; ** initialization of front
; ** Αρχικοποίηση Μετώπου
(defun MakeFront (node)
(list node)
)
; ----------------------------------------------------------------------------
; **** expanding front
; **** επέκταση μετώπου
(defun ExpandFront (front method)
(cond
( (eq method 'DFS) (append ( removeNils ( findchildren (car front))) (cdr front) ) )
( (eq method 'BFS) (append (cdr front) ( removeNils (findchildren (car front)))))
( (eq method 'BESTFS) (sort (append ( removeNils ( findchildren (car front))) (cdr front))#'check) )
( T "other methods to be added" )
)
)
; ----------------------------------------------------------------------------
; **** QUEUE
; **** Διαχείριση ουράς
; ----------------------------------------------------------------------------
; ** initialization of queue
; ** Αρχικοποίηση ουράς
(defun MakeQueue (node)
(list (list node))
)
; ----------------------------------------------------------------------------
; **** expanding queue
; **** επέκταση ουράς
;;; expanding queue
(defun ExtendQueue (queue method)
(cond
( (eq method 'DFS) (append ( growPath (car queue)) (rest queue) ) )
( (eq method 'BFS) (append (rest queue) (growPath (car queue)) ) )
( (eq method 'BESTFS) (sort (append ( growPath (car queue) ) (rest queue))#'check1) )
( T "other methods to be added" )
)
)
(defun check (s1 s2)
(< (+ (third s1) (fourth s1) (fifth s1)) (+ (third s2) (fourth s2) (fifth s2)) )
)
(defun check1 (s1 s2)
(< (+ (third (first s1)) (fourth (first s1)) (fifth (first s1))) (+ (third (first s2)) (fourth (first s2)) (fifth (first s2))))
)
(defvar opt 0) ;Variable definition for the menu
;----------Otptions menu------------------------------------------------------
(defun Options ()
( print "Searching methods." )
( print "For DFS method press 1." )
( print "For BFS method press 2." )
( print "For BESTFS method press 3." )
( print "Choose searching method" )
( let (opt (read)))
(cond
( ( = opt 1 ) (T (DFS) ) )
( ( = opt 2 ) (T (BFS) ) )
( ( = opt 3 ) (T (BESTFS) ) )
)
( T (nil) )
)
; ----------------------------------------------------------------------------
; **** growing path towards each different child of the selected parent node
; **** επεκταση μονοπατιου προς καθε διαφορετικό παιδί-κόμβο από τον επιλεγμένο γονέα-κόμβο
(defun growPath (path)
(removecycles (grow1 path (removeNils (findchildren (car path)))))
)
(defun grow1 (path children)
(cond
((null children) nil )
( T (cons (cons (car children) path) (grow1 path (cdr children))) )
)
)
; ----------------------------------------------------------------------------
; **** Supportive functions
; **** Υποστηρικτικές συναρτήσεις
(defun mymember(x Y)
(cond
((endp y) nil )
((equal x (first y)) T )
(T (mymember x (rest y)) )
)
)
(defun removeNils (X)
(cond
((endp x) nil )
((eq (first x) NIL) (removeNils (rest x)) )
(T (cons (first x) (removeNils (rest x))) )
)
)
(defun removecycles (paths)
(cond
((null paths) nil )
((member (caar paths) (cdar paths)) (removecycles (cdr paths)) )
(T (cons (car paths) (removecycles (cdr paths))) )
)
)
; ----------------------------------------------------------------------------
; **** Problem's World & Problem depending functions
; **** κόσμος του προβλήματος (αν απαιτείται) και συναρτήσεις σχετικές με το πρόβλημα
;;;; #### to be added ####
(defvar capacity 5)
(defun goToGround (state)
(cond
( (or (= (+ (third state) (fourth state) (fifth state)) 0) (= (second state) capacity))
(list 0 0 (third state)(fourth state)(fifth state))
)
(T nil)
)
)
(defun goToFirst (state)
(cond
(
(and (< (second state) capacity) (> (third state) 0))
(goToFirst (list 1 (+ (second state) 1) (- (third state) 1) (fourth state) (fifth state)))
)
(T (list (first state) (second state) (third state) (fourth state) (fifth state)))
)
)
(defun goToSecond (state)
(cond
(
(and (< (second state) capacity) (> (fourth state) 0))
(goToSecond (list 2 (+ (second state) 1) (third state) (- (fourth state) 1) (fifth state)))
)
(T (list (first state) (second state) (third state) (fourth state) (fifth state)))
)
)
(defun goToThird (state)
(cond
(
(and (< (second state) capacity) (> (fifth state) 0))
(goToThird (list 3 (+ (second state) 1) (third state) (fourth state) (- (fifth state) 1)))
)
(T (list (first state) (second state) (third state) (fourth state) (fifth state)))
)
)
; ----------------------------------------------------------------------------
; ** function to find the children nodes of a parent state node
; ** συνάρτηση εύρεσης απογόνων
(defun findchildren (state)
(list (goToGround state) (goToFirst state) (goToSecond state) (goToThird state))
)
; ----------------------------------------------------------------------------
; ** Executing the code
; ** κλήση εκτέλεσης κώδικα
;(trace SearchProblem)
(SearchProblem '(0 0 2 6 4) '(0 0 0 0 0) (Options) )
I heavily recommend you to properly indent common-lisp code following existing guidelines, else the parentheses are a mess.
Here, using slime and regex search and replace, I properly indented your code and simplified some stuff and also by this indenting - discovered some parenthesis mistakes.
And I corrected them.
By the level of the indentation, you can see, where paren mistakes occur.
To your question, I suggest:
(defun options ()
(print "Searching methods.")
(print "For DFS method press 1.")
(print "For BFS method press 2.")
(print "For BESTFS method press 3.")
(print "Choose searching method")
(let ((opt (read))) ;; here were some paren' mistakes!
(case opt ;; case is the `switch` in cl
(1 'DFS)
(2 'BFS)
(3 'BESTFS) ;; here was an erroneous parenthesis
(otherwise 'nil)))) ;; here one paren' added
The whole code correctly indented (using emacs SLIME mode for common-lisp) and with some changes for simplification:
;; --------------------------------------------------
;; ******** Search Code for DFS and other search methods
;; ******** (expanding front and extending queue)
;; ******** author: AI lab
;; ********
;; ******** Κώδικας για DFS και άλλες μεθόδους αναζήτησης
;; ******** (επέκταση μετώπου και διαχείριση ουράς)
;; ******** Συγγραφέας: Εργαστήριο ΤΝ
;; --------------------------------------------------
;; **** starting search
;; **** έναρξη αναζήτησης
(defun searchProblem (start-state goal method)
(if (StateValidation start-state)
(print "Invalid data!") ;; print returns nil
(findSolution (MakeFront start-state)
(MakeQueue start-state)
()
goal
method)))
;;**** Checking for valid states
(defun StateValidation
(or (> (first state) 3)
(< (first state) 0))) ;; if condition is true, returns T else nil
;;--------------------------------------------------
;;**** Basic recursive function to create search tree (recursive tree expantion)
;;**** Βασική αναδρομική συνάρτηση για δημιουργία δέντρου αναζήτησης (αναδρομική επέκταση δέντρου)
(defun FindSolution (front queue closed goal method)
(cond ((null front) 'no_solution)
((mymember (car front) closed)
(FindSolution (cdr front)
(cdr queue)
closed
goal
method))
((equal (car front) goal)
(format T "This is the solution: ~a" (reverse (first queue))))
(T (FindSolution (ExpandFront front method)
(ExtendQueue queue method)
(cons (car front) closed)
goal
method))))
;;--------------------------------------------------
;;**** FRONT
;;**** Διαχείριση Μετώπου
;;--------------------------------------------------
;;** initialization of front
;;** Αρχικοποίηση Μετώπου
(defun MakeFront (node)
(list node))
;;--------------------------------------------------
;;**** expanding front
;;**** επέκταση μετώπου
(defun ExpandFront (front method)
(case method
(DFS (append (removeNils (findchildren (car front)))
(cdr front)))
(BFS (append (cdr front)
(removeNils (findchildren (car front)))))
(BESTFS (sort (append (removeNils (findchildren (car front)))
(cdr front)) #'check))
(otherwise "other methods to be added")))
;;--------------------------------------------------
;;**** QUEUE
;;**** Διαχείριση ουράς
;;--------------------------------------------------
;;** initialization of queue
;;** Αρχικοποίηση ουράς
(defun MakeQueue (node)
(list (list node)))
;;--------------------------------------------------
;;**** expanding queue
;;**** επέκταση ουράς
;;; expanding queue
(defun ExtendQueue (queue method)
(case method
(DFS (append (growPath (car queue))
(rest queue)))
(BFS (append (rest queue)
(growPath (car queue))))
(BESTFS (sort (append (growPath (car queue))
(rest queue)) #'check1))
(otherwise "other methods to be added")))
#|
(defun check (s1 s2)
(< (+ (third s1)
(fourth s1)
(fifth s1))
(+ (third s2)
(fourth s2)
(fifth s2))))
|#
(defun sum-3rd-to-5th (s)
(+ (third s) (fourth s) (fifth s)))
(defun check (s1 s2)
(< (sum-3rd-to-5th s1)
(sum-3rd-to-5th s2)))
(defun check1 (s1 s2)
(check (first s1) (first s2))) ;; this is equivalent to before - uses `check` above
(defvar opt 0) ;Variable definition for the menu
;;----------Otptions menu------------------------------------------------------
(defun options ()
(print "Searching methods.")
(print "For DFS method press 1.")
(print "For BFS method press 2.")
(print "For BESTFS method press 3.")
(print "Choose searching method")
(let ((opt (read))) ;; parenthesis mistakes also here!
(case opt
(1 'DFS)
(2 'BFS)
(3 'BESTFS) ;; here was an erroneous paranthesis
(otherwise 'nil)))) ;; here one added
;;--------------------------------------------------
;;**** growing path towards each different child of the selected parent node
;;**** επεκταση μονοπατιου προς καθε διαφορετικό παιδί-κόμβο από τον επιλεγμένο γονέα-κόμβο
(defun growPath (path)
(removecycles (grow1 path (removeNils (findchildren (car path))))))
(defun grow1 (path children)
(cond ((null children) nil)
(T (cons (cons (car children) path)
(grow1 path (cdr children))))))
;;--------------------------------------------------
;;**** Supportive functions
;;**** Υποστηρικτικές συναρτήσεις
#|
(defun mymember(x y)
(cond ((null y) nil)
((equal x (first y)) T)
(T (mymember x (rest y)))))
(defun removeNils (x)
(cond ((null x) nil)
((eq (first x) NIL) (removeNils (rest x)))
(T (cons (first x)
(removeNils (rest x))))))
|#
(defun mymember (x y)
(member x y :test #'equal))
(defun removeNils (x)
(remove-if #'null x))
(defun removecycles (paths)
(cond ((null paths) nil)
((member (caar paths)
(cdar paths))
(removecycles (cdr paths)))
(T (cons (car paths)
(removecycles (cdr paths))))))
;;--------------------------------------------------
;;**** Problem's World & Problem depending functions
;;**** κόσμος του προβλήματος (αν απαιτείται) και συναρτήσεις σχετικές με το πρόβλημα
#| isn't state a list of 5 elements?
(list (first state)
(second state)
(third state)
(fourth state)
(fifth state)) ;; ===> state
|#
;;;; #### to be added ####
(defvar capacity 5)
(defun goToGround (state)
(if (or (zerop (sum-3rd-to-5th state))
(zerop (second state) capacity))
(list 0
0
(third state)
(fourth state)
(fifth state))
nil))
(defun goToFirst (state)
(if (and (< (second state) capacity)
(> (third state) 0))
(goToFirst (list 1
(1+ (second state))
(1- (third state))
(fourth state)
(fifth state)))
state))
(defun goToSecond (state)
(if (and (< (second state) capacity)
(> (fourth state) 0))
(goToSecond (list 2
(1+ (second state))
(third state)
(1- (fourth state))
(fifth state)))
state))
(defun goToThird (state)
(if (and (< (second state) capacity)
(> (fifth state) 0))
(goToThird (list 3
(1+ (second state))
(third state)
(fourth state)
(1- (fifth state))))
state))
;;--------------------------------------------------
;;** function to find the children nodes of a parent state node
;;** συνάρτηση εύρεσης απογόνων
(defun findchildren (state)
(list (goToGround state)
(goToFirst state)
(goToSecond state)
(goToThird state)))
;;--------------------------------------------------
;;** Executing the code
;;** κλήση εκτέλεσης κώδικα
;; (trace SearchProblem)
(SearchProblem '(0 0 2 6 4)
'(0 0 0 0 0)
(Options))
You're trying to call DFS, BFS, and BESTFS as functions. They're just symbols that should be returned, and they'll be passed on to other functions as parameters.
They shouldn't be wrapped in (T ...), either. And (T (nil)) needs to be a clause of the COND, not after it. And again, nil shouldn't be inside parentheses, that means to try to call it as a function. You don't really need this clause, though, since COND returns NIL by default if none of the conditions match.
The code that tests opt needs to be inside the let that binds it.
(defun Options ()
( print "Searching methods." )
( print "For DFS method press 1." )
( print "For BFS method press 2." )
( print "For BESTFS method press 3." )
( print "Choose searching method" )
( let (opt (read))
(cond
( ( = opt 1 ) 'DFS )
( ( = opt 2 ) 'BFS )
( ( = opt 3 ) 'BESTFS )
( T nil )))
)
)
I'm excise example from book: ANSI Common Lisp, charpter 14.6 conditions.
But the check-type and assert example doesn't work in sbcl.
And how can I input new value? it is always failed no matter whatever new value I input.
However, it works in clisp.
example code:
(let ((x '(a b c))) (check-type (car x) integer "an integer") x)
(let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
((car sandwich))
"I wanted a ~a sandwich." 'chicken)
sandwich)
In sbcl:
example 1:
* (let ((x '(a b c))) (check-type (car x) integer "an integer") x)
; in: LET ((X '(A B C)))
; (CHECK-TYPE (CAR X) INTEGER "an integer")
; --> DO BLOCK LET TAGBODY TAGBODY SETF
; ==>
; (SB-KERNEL:%RPLACA X
; (SB-KERNEL:CHECK-TYPE-ERROR '(CAR X) #:G0 'INTEGER
; "an integer"))
;
; caught WARNING:
; Destructive function SB-KERNEL:%RPLACA called on constant data.
; See also:
; The ANSI Standard, Special Operator QUOTE
; The ANSI Standard, Section 3.2.2.3
;
; compilation unit finished
; caught 1 WARNING condition
debugger invoked on a SIMPLE-TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
The value of (CAR X) is A, which is not an integer.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [STORE-VALUE] Supply a new value for (CAR X).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:CHECK-TYPE-ERROR (CAR X) A INTEGER "an integer")
0] 0
Type a form to be evaluated: 0
debugger invoked on a SIMPLE-TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
The value of (CAR X) is A, which is not an integer.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [STORE-VALUE] Supply a new value for (CAR X).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:CHECK-TYPE-ERROR (CAR X) A INTEGER "an integer")
0]
example2:
* (let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
((car sandwich))
"I wanted a ~a sandwich." 'chicken)
sandwich)
; in: LET ((SANDWICH '(HAM ON RYE)))
; (ASSERT (EQL (CAR SANDWICH) 'CHICKEN) ((CAR SANDWICH))
; "I wanted a ~a sandwich." 'CHICKEN)
; --> TAGBODY SETF
; ==>
; (SB-KERNEL:%RPLACA SANDWICH
; (SB-IMPL::ASSERT-PROMPT '(CAR SANDWICH) (CAR SANDWICH)))
;
; caught WARNING:
; Destructive function SB-KERNEL:%RPLACA called on constant data.
; See also:
; The ANSI Standard, Special Operator QUOTE
; The ANSI Standard, Section 3.2.2.3
;
; compilation unit finished
; caught 1 WARNING condition
debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
I wanted a CHICKEN sandwich.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [CONTINUE] Retry assertion with new value for (CAR SANDWICH).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:ASSERT-ERROR (EQL (CAR SANDWICH) (QUOTE CHICKEN)) (((CAR SANDWICH) HAM)) ((CAR SANDWICH)) "I wanted a ~a sandwich." CHICKEN)
0] 0
The old value of (CAR SANDWICH) is HAM.
Do you want to supply a new value? (y or n) y
Type a form to be evaluated:
'chicken
debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
I wanted a CHICKEN sandwich.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [CONTINUE] Retry assertion with new value for (CAR SANDWICH).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:ASSERT-ERROR (EQL (CAR SANDWICH) (QUOTE CHICKEN)) (((CAR SANDWICH) HAM)) ((CAR SANDWICH)) "I wanted a ~a sandwich." CHICKEN)
0]
But in clisp, it works well.
[1]> (let ((x '(a b c))) (check-type (car x) integer "an integer") x)
*** - The value of (CAR X) should be an integer.
The value is: A
The following restarts are available:
STORE-VALUE :R1 Input a new value for (CAR X).
ABORT :R2 Abort main loop
Break 1 [2]> :R1
New (CAR X)> 99
(99 B C)
[3]> (let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
You are in the top-level Read-Eval-Print loop.
Help (abbreviated :h) = this list
Use the usual editing capabilities.
(quit) or (exit) leaves CLISP.
((car sandwich))
You are in the top-level Read-Eval-Print loop.
Help (abbreviated :h) = this list
Use the usual editing capabilities.
(quit) or (exit) leaves CLISP.
"I wanted a ~a sandwich." 'chicken)
sandwich)
** - Continuable Error
I wanted a CHICKEN sandwich.
If you continue (by typing 'continue'): Input a new value for (CAR SANDWICH).
The following restarts are also available:
ABORT :R1 Abort main loop
Break 1 [4]> continue
New (CAR SANDWICH)> 'chicken
(CHICKEN ON RYE)
[5]>
You are not supposed to modify literal data. The consequences are undefined in the Common Lisp standard.
This is undefined:
(let ((x '(a b c)))
(setf (car x) 10))
This works:
(let ((x (list 'a 'b 'c)))
(setf (car x) 10))
I'm trying to make a Mancala game in Lisp. It's going to have an AI to play against a human player, but I'm stuck. I can't find the way to represent the board as list; the major issue in my mind is how to move the tokens. Here are the references of how to play mancala
I'm thinking about a circular list, but I can't find any clear documentation on how to do that in Lisp.
Sorry about my grammar; English is not my native language.
Now I havent read the rules (sorry!) so this is just to address the idea of using a circular data structure.
A data structure doesnt have to be circular. As long as you pretend it is it will work!
Have a read of the mod function.
;; a1 a6 b1 b6
(defparameter *board* '(nil nil nil nil nil nil nil nil nil nil nil nil))
(defun wrap-position (pos)
(mod pos (length *board*)))
(defun push-token (position)
(push t (nth (wrap-position position) *board*)))
(defun pull-token (position)
(let ((contents (nth (wrap-position position) *board*)))
(setf (nth (wrap-position position) *board*) (rest contents))))
(defun print-board ()
(format t "| ~{~10<~a~>~} |~%| ~{~10<~a~>~} |" (reverse (subseq *board* 6))
(subseq *board* 0 6))
*board*)
Now the technique above is destructive. If you don't know yet what that is in lisp have a google or search here on stackoveflow, there are some good descriptions. It is worth looking into as you may find that your AI want to 'try out' lots of potential moves with 'damaging' the actual game board, a non destructive approach can help with this. The phenomenal book land of lisp has some great info on this.
Here is a simple usage example
CL-USER> *board*
(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)
CL-USER> (push-token 5)
(T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T) NIL NIL NIL NIL NIL NIL)
CL-USER> (push-token 5)
(T T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T T) NIL NIL NIL NIL NIL NIL)
CL-USER> (PULL-token 5)
(T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T) NIL NIL NIL NIL NIL NIL)
...I change the board before doing the next bit...
CL-USER> (print-board)
| NIL NIL NIL NIL NIL NIL |
| NIL NIL NIL NIL NIL (T T T T) |
Now have a look at Sylwester's answer and see that you can replace the sublists with just a number of stones. You will need to change the print-board obviously but that gives you a very simple model you can manipulate very easily (almost can be the big step you need to make this non-destructive). Have a go!
I would have used an array of 14 fixnums. index 0-5 are pits for A, 6 is A's basket. 7-12 are pits for player B and 13 is B's basket. You do minimax with copy-array.
If you want lists I would have either had A and B's lists individually or interleaved them. You could also just have a list of 14 cons.
Sorry, I couldn't really understand how to play the game, but here's something I could think about w/r to how to go about the board:
(defstruct (mancala-cell
(:print-object
(lambda (cell stream)
(format stream "<stones: ~d>"
(length (mancala-cell-stones cell))))))
(stones nil :type list)
(next nil))
(defun make-cells ()
(labels ((%make-cells (head count)
(let ((next (make-mancala-cell)))
(setf (mancala-cell-next head) next)
(if (> count 0) (%make-cells next (1- count)) next))))
(let* ((first (make-mancala-cell))
(last (%make-cells first 12)))
(setf (mancala-cell-next last) first))))
(defstruct (mancala-board
(:print-object
(lambda (board stream)
(loop :for i :from 0 :below 12
:for cell := (mancala-board-cells board)
:then (mancala-cell-next cell)
:do (princ (case i
(6 #\Newline) (0 "") (otherwise #\-))
stream)
(princ cell stream)))))
(cells (make-cells) :type mancala-cell))
(print (make-mancala-board))
;; <stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>
;; <stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>
Then here's one more example:
(defstruct (mancala-cell
(:print-object
(lambda (cell stream)
(format stream "<stones: ~d>"
(mancala-cell-stones cell)))))
(stones 4 :type fixnum))
(defconstant +null-cell+ (make-mancala-cell))
(deftype mancala-grid () '(array mancala-cell (12)))
(defun make-cells ()
(loop
:for i :from 0 :below 12
:with result := (make-array
12 :element-type 'mancala-cell
:initial-element +null-cell+)
:do (setf (aref result i) (make-mancala-cell))
:finally (return result)))
(defstruct (mancala-board
(:print-object
(lambda (board stream)
(loop :for i :from 0 :below 12
:for cell :across (mancala-board-cells board)
:do (princ (case i
(6 #\Newline) (0 "") (otherwise #\-))
stream)
(princ cell stream)))))
(cells (make-cells) :type mancala-grid))
(defun map-cells-in-range (function board &key (start 0) (end 12))
(loop
:for i :from start :below end
:with board := (mancala-board-cells board)
:collect (funcall function (aref board (mod i 12)))))
(defun fold-cells-in-range (function board &key (start 0) (end 12))
(loop
:for i :from start :below (1- end)
:with board := (mancala-board-cells board)
:for cell := (aref board (mod i 12))
:for result := (funcall
function
(aref board (mod i 12))
(aref board (mod (1+ i) 12)))
:then (funcall function result (aref board (mod (1+ i) 12)))
:finally (return result)))
(fold-cells-in-range
(lambda (a b)
(+ (mancala-cell-stones b)
(if (integerp a) a (mancala-cell-stones a))))
(make-mancala-board)) ; 48