(SETQ L '(A B C D))
(DEFUN my-first (LST)
(CAR LST))
(DEFUN my-rest (LST)
(CDR LST))
(DEFUN my-construct (A LST)
(CONS A LST))
(DEFUN rotate-left (LST)
(APPEND (CDR LST) (LIST(CAR LST))))
(DEFUN rotate-right (LST)
(APPEND (LAST LST)(REVERSE(CDR(REVERSE LST)))))
(DEFUN palindrom (LST)
(APPEND LST (REVERSE LST)))
(DEFUN EC2 (A B C)
(LIST (/ (+ (- B) (SQRT (- (* B B) (* 4 (* A C))))) (* 2 A)) (/ (- (- B) (SQRT (- (* B B) (* 4 (* A C))))) (* 2 A))))
(DEFUN my-evenp (A)
(if (ZEROP (REM A 2)) (write t) (write nil)))
(DEFUN my-palindromp (LST)
(if(EQUAL LST (REVERSE LST)) (write t) (write nil)))
(DEFUN not-realp(A B C)
(if(MINUSP (- (* b b) (* 4 a c))) (write t) (write nil)))
(format t "My first CAR:")
(print (my-first L))
(format t "~%My first CDR:")
(print (my-rest L))
(format t "~%My first CONS:")
(print (my-construct '(X) L))
(format t "~%Rotate Left:")
(print (rotate-left L))
(format t "~%Rotate Left Twice:")
(print (rotate-left (rotate-left L)))
(format t "~%Rotate Right:")
(print (rotate-right L))
(format t "~%Rotate Right Twice:")
(print (rotate-right (rotate-right L)))
(format t "~%Palindrome of the list with double length:")
(print (palindrom L))
(format t "~%Roots of ecuation:")
(print (EC2 1 -5 6))
(format t "~%Checking if Even~%")
(my-evenp (* 15 2))
(format t "~%Checking if Palindrome~%")
(my-palindromp L)
(format t "~%Checking if Not Real~%")
(not-realp 1 -2 6)
(SETQ A -10)
(SETQ B 7)
(SETQ C nil)
(COND ((MINUSP A) (format t "~%Value of abs(~d) is:~d~%" a (- a))) (t (format t "~%Value of abs(~d) is:~d~%" a a)))
(COND ((> A B) (format t "Maximum of ~d and ~d is:~d~%" a b a)) (t (format t "Maximum of ~d and ~d is:~d~%" a b b)))
(COND ((< A B) (format t "Minumum of ~d and ~d is:~d~%" a b a)) (t (format t "Minimum of ~d and ~d is:~d~%" a b b)))
(COND ((NOT A) (write t)) (t(write nil)))
(format t "~%")
(COND ((NOT C) (write t)) (t(write nil)))
(format t "~%")
(COND ((OR A B C) (write t))(t(write nil)))
(format t "~%")
(COND ((AND A B C) (write t))(t(write nil)))
(print (cons(car nil)(cdr nil)))
(format t "~%")
(DEFUN MEDIAN-OF-THREE(A B C)
(COND((AND (> A B)(< A C)) (write A))
((AND (< A B)(> A C)) (write A))
((AND (< B A)(> B C)) (write B))
((AND (< B C)(> B A)) (write B))
((AND (< C B)(> C A)) (write A))
((AND (< C A)(> C B)) (write A))))
(MEDIAN-OF-THREE 20 25 12)
(SETQ L '(A B C D))
;problem 1
(format t "My-first CAR")
(defun my-first (lst)
( car lst)
)
(print (my-first L))
(format t "~%My-rest CDR")
(defun my-rest (lst)
(cdr lst)
)
(print(my-rest L))
(format t "~%Construct")
(defun construct (lst)
(cons (car lst) (cdr lst))
)
(print (construct L))
;problem 2
(format t "~%Rotate-left")
(defun rotate-left (lst)
(append (CDR lst) (list(car lst)))
)
(print (rotate-left L))
(format t "~%Double rotate-left")
(print (rotate-left (rotate-left L)))
;problem 3
(format t "~%Rotate-right")
(defun rotate-right (lst)
( append (LAST lst) (reverse (cdr(reverse lst))) )
)
(print (rotate-right L))
(format t "~%Double rotate-right")
(print (rotate-right (rotate-right L)))
;problem 4
(format t "~%Palindrom")
(defun palindrom (lst)
(append lst (reverse lst) )
)
(print (palindrom L))
;problem 5
(format t "~%Quadratic")
(defun ec2 (a b c)
(list (/(+(- b) (SQRT(-(* b b) (* 4 a c)))) (* 2 a)) (/(-(- b) (SQRT(-(* b b) (* 4 a c )))) (* 2 a)))
)
(print (ec2 2 7 6))
;;; useful functions for LISP natural language parsing program
;;; Set up the parse-obj and word-dict
(setf parse-obj (MAKE-HASH-TABLE))
(setf word-dict (MAKE-HASH-TABLE))
(setf table-ht (MAKE-HASH-TABLE))
;;; processRequest
;;; Parameters:
;;; request - a list of words making a request
;;; Purpose:
;;; - Sets up necessary information (see below) and invokes the student's checkRequest
;;; function.
;;; - Since the student's checkRequest sets the parts of speech, processRequest prints
;;; those parts of speech.
;;; - Returns T if the request is a valid request. Otherwise, NIL is returned.
;;; Notes:
;;; - Sets the parse-obj hash table to contain the request
;;; - Sets the cursor position to zero.
;;; - Uses resetPartsOfSpeech to reset the values of each part of speech.
;;; - Prints the request
;;; - Invokes checkRequest to check for valid syntax and prints
;;; the result.
;;; - Prints the value for each part of speech
;;; - Invokes makeDBRequest to generate a database request from the parts of speech
;;; Notes:
;;; - Requests will not contain punctuation since
;;; -- commas have a meaning in Common LISP associated with backquote
;;; -- periods are used for dotted pairs
;;;
(defun processRequest(request)
(PROG (result)
;;; Save the request in parse-obj.
(putp 'request parse-obj request) ;; KEY=request; VAL=whatever the request was
;;; Set the cursor position to 0.
(putp 'cursor parse-obj 0)
;;; reset the parts of speech to NIL
(resetPartsOfSpeech parse-obj 'verb 'directObj 'prep 'indirectObj 'QualIndirectPrep 'QualIndirectObj)
(resetPartsOfSpeech parse-obj 'Comparator 'NotQual 'QualPrep 'QualValue)
(format T "~% ******************************************************************")
(format T "~% ~a" request)
(setf result (checkRequest parse-Obj))
(format T "~% checkRequest returned ~a" result)
(format T "~% verb= ~a" (getp 'verb parse-obj))
(format T "~% directObj= ~a" (getp 'directObj parse-obj))
(format T "~% prep= ~a" (getp 'prep parse-obj))
(format T "~% indirectObj= ~a" (getp 'indirectObj parse-obj))
;;; if we have a qual indirect, show it (SECOND FORM)
(cond ((or (getp 'QualIndirectPrep parse-obj)
(getp 'QualIndirectObj parse-obj))
(format T "~% QualIndirectPrep= ~a" (getp 'QualIndirectPrep parse-obj))
(format T "~% QualIndirectObj= ~a" (getp 'QualIndirectObj parse-obj))
))
(cond ((or (getp 'Comparator parse-obj)
(getp 'NotQual parse-obj)
(getp 'QualPrep parse-obj)
(getp 'QualValue parse-obj))
(if (getp 'NotQual parse-obj)
(format T "~% NotQual = ~a" (getp 'NotQual parse-obj)))
(format T "~% Comparator= ~a" (getp 'Comparator parse-obj))
(format T "~% QualPrep= ~a" (getp 'QualPrep parse-obj))
(format T "~% QualValue= ~a" (getp 'QualValue parse-obj))
))
(if (not result) (return result))
;;; see if doing extra credit, return if not
(if (NOT doingExtra)
(return result))
;;; generate the SQL and show that SQL query
(setf query (genSQL parse-Obj))
(format T "~% DBRequest= ~a" query)
(return result) ) )
;;; putp
;;; Parameters:
;;; symbol - symbol to be given the property value
;;; ht - hash table to store the symbol and its property value
;;; value - the property value
;;; Purpose:
;;; stores the property value for the symbol in the specified hash table
;;; Notes:
;;; If the symbol isn't an ATOM, putp breaks execution with an ERROR.
;;; Example Usage:
;;; (putp 'prep parse preposition)
;;; (putp word word-dict partOfSpeech)
;;; KEY VALUE
(defun putp (symbol ht value)
(if (ATOM symbol)
(setf (gethash symbol ht) value)
(ERROR "~s is not a valid symbol for putp" symbol)
)
)
;;; getp
;;; Parameters:
;;; symbol - symbol about which we want its property value
;;; ht - hash table which stores the symbol and its property value
;;; Purpose:
;;; Returns the property value for the symbol in the specified hash table
;;; If not found, it returns NIL.
;;; Example Usage:
;;; (getp word word-dict) would return the partOfSpeech for that word
;;; (getp 'request parse-obj) would return the original request from the parse-obj.
(defun getp (symbol ht)
(gethash symbol ht) )
;;; getCursor
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; Purpose:
;;; returns the current cursor position (relative to zero)
(defun getCursor (parse)
(getp 'cursor parse) ) ;; should be a number
;;; setCursor
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; cursorPosition - new cursor position
;;; Purpose:
;;; Sets the value of the cursor position (relative to zero) in the
;;; parse object
;;; Notes:
;;; If the cursorPosition isn't a numeric, setCursor breaks execution
;;; with an ERROR.
(defun setCursor (parse cursorPosition)
(if (numberp cursorPosition)
(putp 'cursor parse cursorPosition)
(ERROR "~s is not a numeric argument for setCursor" cursorPosition)
)
)
;;; getToken
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; Purpose:
;;; returns the next token from the request. If there are no more
;;; tokens, it returns NIL.
;;; Notes:
;;; This modifies the cursor position after getting the current token
;;; at the old position.
(defun getToken (parse)
(prog (temp)
(setf temp (nth (getp 'cursor parse) (getp 'request parse)))
(setCursor parse (1+ (getp 'cursor parse)))
(return temp) ) )
;;; checkRequest
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; Purpose:
;;; Checks for a valid reqest according based on the request passed in
;;; from the parse-obj and returns T if the request is valid; otherwise
;;; it returns NIL. Additionally, checkRequest also saves identified parts
;;; of speech.
;;; Notes:
;;; -Parts of speech are validated at the end based on what values they
;;; have in the parse-obj hash table.
;;; -wordCount keeps a count of the number of words passed in and
;;; articleCount keeps a count of the number of articles passed in. This
;;; is done to determine which form the request is in by doing
;;; wordCount - articleCount
(defun checkRequest (parse)
(PROG (result)
(setf result T) ; initially T unless otherwise later
(setf word (getToken parse))
(setf articleCount 0) ; keep track of article count
(do ()
((NULL word)) ; loop until no more words
(setf wordCount (getCursor parse)) ; authorizes which conditions to enter
(if (isa word 'verb) (putp 'verb parse word))
(if (isa word 'article) ; if word was an article increment count
(prog ()
(putp 'article parse word)
(+= articleCount 1) ) )
;; FIRST FORM (VERB DIRECTOBJ PREP INDIRECTOBJ)
(if (EQL (- wordCount articleCount) 3)
(prog ()
(if (isa word 'prep) (putp 'prep parse word))
; Set back by 2 to get directObj
(setCursor parse (- (getCursor parse) 2))
(setf w (getToken parse))
(if (isa w 'noun) (putp 'directObj parse w))
; Set forward by 1 to get indirectObj
(setCursor parse (+ 1 (getCursor parse)))
(setf w (getToken parse))
(if (isa w 'article) ; check for article
(prog ()
(setf w (getToken parse)) ; sets cursor forward
(putp 'article parse word)
(+= articleCount 1) ) )
(if (isa w 'noun) (putp 'indirectObj parse w) ) ) )
;; SECOND FORM (FIRSTFORM + QUALIFIERS + COMPARATOR) 1/2
(if (EQL (- wordCount articleCount) 5)
(prog ()
(if (isa word 'prep) (putp 'QualIndirectPrep parse word))
(setf w (getToken parse)) ; check for article
(if (isa w 'article)
(prog ()
(setf w (getToken parse))
(putp 'article parse word)
(+= articleCount 1) ) )
(if (isa w' adjective) ;check for adjective
(prog ()
(putp 'QualValue parse w) ; set it as QualValue
(setf w (getToken parse)) ; in order to get QualInObj
(putp 'comparator parse 'EQUAL) ; hardcoded for adjective
(putp 'QualPrep parse 'TO) ) ) ; hardcoded for adjective
(if (isa w 'noun) (putp 'QualIndirectObj parse w)) ) )
;; SECOND FORM (FIRSTFORM + QUALIFIERS + COMPARATOR) 2/2
(if (EQL (- wordCount articleCount) 7)
(prog ()
(if (EQL word 'NOT) ; check for NotQual
(prog ()
(putp 'NotQual parse word)
(setf word (getToken parse)) ) )
(if (isa word 'comparator) (putp 'comparator parse word))
(setf w (getToken parse)) ; w=prep || w=QualVal
(if (isa w 'prep) ; check for optional QualPrep
(prog ()
(putp 'QualPrep parse w)
(setf w (getToken parse)) ) ) ; move up cursor if QualPrep
(if (NULL (getp 'QualValue parse)) (putp 'QualValue parse w)) ) )
(setf word (getToken parse)) )
;; ALWAYS CHECK
(if (NULL (getp 'verb parse)) (return NIL))
(if (NULL (getp 'directObj parse)) (return NIL))
(if (NULL (getp 'prep parse)) (return NIL))
(if (NULL (getp 'indirectObj parse)) (return NIL))
;; CHECK IF MORE THAN 4 WORDS (SECOND FORM)
(if (AND (> wordCount 4) (NULL (getp 'QualIndirectPrep parse))) (return NIL))
(if (AND (> wordCount 4) (NULL (getp 'QualIndirectObj parse))) (return NIL))
(if (AND (NOT (NULL (getp 'NotQual parse))) (NOT (EQL (getp 'NotQual parse)'NOT))) (return NIL))
(if (AND (> wordCount 4) (NULL (getp 'comparator parse))) (return NIL))
(if (AND (> wordCount 4) (NULL (getp 'QualValue parse))) (return NIL))
(return result) ) )
;;; genSQL
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; Purpose:
;;; Generates and returns a list containing a well formed SQL statement.
;;; Notes:
;;; -If the verb is COUNT, it generates SELECT COUNT(*). Otherwise it
;;; generates SELECT directObj.
;;; -The FROM tableName uses table-ht to generate the correct table name.
;;; -If there is a QualifyingPhrase, WHERE clause is generated.
(defun genSQL (parse)
(prog (result)
(if (EQL (getp 'verb parse) 'count)
(setf verb "SELECT count(*)") ; verb was COUNT
(setf verb "SELECT")) ; verb was NOT COUNT
(setf from "FROM")
(setf where "WHERE")
(setf directObj (getp 'directObj parse))
(setf tableName (getp 'IndirectObj parse))
(if (EQUAL verb "SELECT")
(putp 'request parse (LIST verb directObj from (getp tableName table-ht)))
(putp 'request parse (LIST verb from (getp tableName table-ht))))
(setf result (getp 'request parse))
;; SECOND FORM
(if (NOT (NULL (getp 'QualIndirectObj parse)))
(prog ()
(setf QualIndObj (getp 'QualIndirectObj parse))
(setf comp (getp 'comparator parse))
(setf notQual (getp 'NotQual parse))
(setf qualValue (getp 'QualValue parse))
(if (EQL comp 'EQUAL) (setf comp '=)) ; EQUAL -> "="
(if (EQL comp 'AFTER) (setf comp '>)) ; AFTER -> ">"
(if (EQL comp 'BEFORE) (setf comp '<)) ; BEFORE -> "<"
; adjust comparator if we have a NotQual
(if (AND (NOT (NULL notQual)) (EQL comp '=)) (setf comp '<>))
(if (AND (NOT (NULL notQual)) (EQL comp '>)) (setf comp '<=))
(if (AND (NOT (NULL notQual)) (EQL comp '<)) (setf comp '>=))
(setf qualValue (format NIL "\"~a\"" qualValue))
(setf where (LIST where QualIndObj comp qualValue))
; Append lists together
(putp 'request parse (APPEND result where))
(setf result (getp 'request parse)) ) )
(return result) ) ) ; return SQL statement
;;; resetPartsOfSpeech
;;; Parameters:
;;; parse - the parse object containing a request, cursor position, and
;;; value for each part of speech
;;; speech - x number of words to be reset to NILL
;;; Purpose:
;;; Resets the value for each of the specified parts of speech to NILL
;;; using putp.
(defun resetPartsOfSpeech (parse &rest speech)
(dolist (part speech) (putp part parse NIL))
)
;;; set_isa
;;; Parameters:
;;; word - word that will have parts of speech that define as that word
;;; i.e. WORD=VALUE
;;; partOfSpeech - x number of words that will define word
;;; i.e. partsOfSpeech=KEYS
;;; Purpose:
;;; Defines each word in the list of words to be specified partOfSpeech
;;; in the dictionary (hard coded word-dict).
;;; Notes:
;;; Uses putp to put each word in the word-dict hash table.
(defmacro set_isa (word &rest partOfSpeech)
(dolist (part partOfSpeech) (putp part word-dict word))
)
;;; isa
;;; Parameters:
;;; word - word to be compared to grammar in parse-obj
;;; partOfSpeech - grammar in parse-obj
;;; Purpose:
;;; Returns T if the specified word is that specified partOfSpeech,
;;; otherwise return NIL.
;;; Example Usage:
;;; (isa show 'verb) would return T since "show" is a verb
;;; (isa with 'verb) would return NIL since "with" is not a verb
(defun isa (word partOfSpeech)
(COND ((EQL (getp word word-dict) partOfSpeech)))
)
;;; +=
;;; Parameters:
;;; num - represents number variable to be
;;; incremented
;;; inc - represents increment value
;;; Purpose:
;;; Takes in a variable which is incremented
;;; and assigns the new value to that variable
;;; Expansion example:
;;; x=10; num=x; inc=5
;;;
;;; (+= (X 5)
;;; (SETF X (+ X 5 ) )
;;; )
(defmacro += (num inc)
`(setf ,num (+ ,num ,inc))
)
;;; defaulting doingExtra to NIL
(setf doingExtra 'EC2)
;;; p4LispRun.txt - run the student's code
;;; Use set_isa to set the part of speech for each of the words.
(set_isa article a an the)
(set_isa noun movies movie rentals rental customer customers)
(set_isa noun ID title genre rating custNr name state date number gender)
(set_isa verb count select show print)
(set_isa prep of with to in for)
(set_isa comparator equal after before)
(set_isa adjective horror scifi romance comedy action male female g pg pg13 r x )
(putp 'movie table-ht 'movie)
(putp 'movies table-ht 'movie)
(putp 'rental table-ht 'rental)
(putp 'rentals table-ht 'rental)
(putp 'customer table-ht 'customer)
(putp 'customers table-ht 'customer)
;;;
;;; first form: verb [article] directObj prep [article] indirectObj
;;;
(processRequest '(count the number of rentals ))
(processRequest '(count the number of movies ))
(processRequest '(show ID for movies ))
;;;
;;; second form: verb [article] directObj prep [article] indirectObj
;;; prep [article] qualIndirectObj comparator [prep] qualValue
;;;
(processRequest '(show the title of movies with rating equal to PG13))
(processRequest '(Count the number of rentals with date after 2018-10-01))
(processRequest '(Show the title for the movie with ID equal to HP001))
(processRequest '(Select the name of the customer with custNr not before to 111))
;;;
;;; Examples with NOT
;;;
(processRequest '(Show title for movies with rating not equal to G))
;;;
;;; Some invalid requests
;;;
(processRequest '(Show title for videos with a rating of G))
(processRequest '(Show title for movies having a rating of G))
(processRequest '(Show title for movies with a rating of G or PG))
;;; see if doing extra credit, return if not
(if (NOT(EQL doingExtra 'EC2))
(abort))
(processRequest '(Show the title of movies in the horror genre))
(processRequest '(Show the genre of movies with a G rating))
(processRequest '(Count the number of customers with a male gender))
(processRequest '(Count the number of movies with a PG13 rating))
(setq a (read) b (read))
;;;;;
(if (and (string-equal (typep a 'integer) "T") (string-equal (typep b 'integer) "T"))
(progn
;;;;;
(when (and (= 6 a) (= 2 b))
(format t "~%It's the 15th variant :3~%~%"))
(defun task15(x)
(setq y (* a (/ (sin x)(+(+ b 0)(cos x)))) ))
(setq i 0)
(loop (setq i (+ i 0.1))
(write (task15 i))
(terpri)
(when (> i 2.9) (return i)))
;;;;;
)
(format t "~% ERROR"
))
;;;;;
(defstruct city name neighbors h visited)
(defvar *acl* nil)
(defvar *acht* (make-hash-table))
(defun set-neighbors (city neighbors)
(loop for nei in neighbors
do (setf (city-neighbors city) (push nei (city-neighbors city)))))
(defun set-neighbors-from-namelist (city namelist)
(loop for name in namelist
do (setf (city-neighbors city) (push (get-city-from-list name) (city-neighbors city)))))
;(defun read-file (file)
; (with-file-open (in file)
; (read in)))
(defun read-file (path-to-file)
(with-open-file (s path-to-file) (read s)))
;(defun read-file (filename)
; (with-open-file (stream filename)
; (loop for line = (read-line stream nil)
; while line
; collect line)))
(defun setup-cities (file)
(setf str (read-file file))
(setf cities
(loop for city in str
collect (make-city :name (car city) :neighbors nil :h (cadr city))
)
)
(setf *acl* cities)
(loop for current in str
for city in *acl*
do (set-neighbors-from-namelist city (caddr current))
)
)
(defvar *city1* (make-city :name "Bucharest" :neighbors nil :h 0))
(defvar *city2* (make-city :name "Pitesti" :neighbors nil :h 100))
(defvar *city3* (make-city :name "Rimnicu Vilcea" :neighbors nil :h 193))
(defvar *city4* (make-city :name "Sibiu" :neighbors nil :h 253))
(defvar *city5* (make-city :name "Fagaras" :neighbors nil :h 176))
(set-neighbors *city1* (list (list *city2* 101) (list *city5* 211)))
(set-neighbors *city2* (list (list *city1* 101) (list *city3* 97)))
(set-neighbors *city3* (list (list *city2* 97) (list *city4* 80)))
(set-neighbors *city4* (list (list *city3* 80) (list *city5* 99)))
(set-neighbors *city5* (list (list *city1* 211) (list *city4* 99)))
(setf *acl* (push *city1* *acl*))
(setf *acl* (push *city2* *acl*))
(setf *acl* (push *city3* *acl*))
(setf *acl* (push *city4* *acl*))
(setf *acl* (push *city5* *acl*))
(setf (gethash '1 *acht*) *city1*)
(setf (gethash '2 *acht*) *city2*)
(setf (gethash '3 *acht*) *city3*)
(setf (gethash '4 *acht*) *city4*)
(setf (gethash '5 *acht*) *city5*)
(defun city-print (city)
(print (format nil "City Name: ~D" (string (city-name city))))
(print (format nil "Neighbors:"))
(loop for nei in (city-neighbors city)
do (print (format nil "~D: ~D miles away" (city-name (car nei)) (cadr nei)))
)
(print (format nil "Distance to Bucharest: ~D~%" (city-h city))))
(defun all-cities-from-list (cities)
(loop for cit in cities
collect (city-name cit)))
(defun all-cities-from-htable (cities)
(loop for value being the hash-values of cities
collect value))
(defun get-city-from-list (cname)
;Take city name, return corresponding structure
(loop for cit in *acl*
do
(if (equalp (city-name cit) cname)
(return-from get-city-from-list cit))))
(defun get-city-from-htable (cname)
;Take city name, return corresponding structure
(loop for value being the hash-values of *acht*
do
(if (equalp (city-name value) cname)
(return-from get-city-from-htable value))))
(defun neighbors-using-list (cname)
;Take city name, return list of neighbor structures
;NOTE: Returns the ASSOCIATED LIST FORM (structure, dist)
(setf city (get-city-from-list cname))
(loop for nei in (city-neighbors city)
collect nei))
(defun neighbors-using-htable (cname)
;Take city name, return list of neighbor structures
;NOTE: Returns the ASSOCIATED LIST FORM (structure, dist)
(setf city (get-city-from-htable cname))
(loop for nei in (city-neighbors city)
collect nei))
(defun neighbors-within-d (my-city distance)
;Take city name, return list of all direct neighbors within the given distance (inclusive).
(setf neighbors (neighbors-using-list (city-name my-city)))
(loop for nei in neighbors
when (<= (cadr nei) distance) collect (car nei)
)
)
(defun neighbors-p (cn1 cn2)
;Takes two city names, returns distance between if neighbors (nil if not).
(setf c1 (get-city-from-list cn1))
(setf c2 (get-city-from-list cn2))
(loop for nei in (city-neighbors c1)
do (if (equalp c2 (car nei))
(return-from neighbors-p (cadr nei))
)
)
)
(defstruct node city parent children path cost)
;Path is a list of city NAMES, starting with root and ending with itself.
(defun get-node-from-nodelist (city)
(loop for node in *nodelist*
do (if (equal (node-city node) city)
(return-from get-node-from-graph node)
)
)
nil)
(defun evaluate-node-g (node)
(do
(
(path (node-pathval node) (rest path))
(temp 0 (+ temp (neighbors-p (car path) (cadr path))))
)
((not (cadr path)) temp)))
(defun evaluate-fringe (fringe)
(let (result resultDist)
(setf resultDist 999999999)
(if (not fringe) (print "FRINGE IS EMPTY") )
(loop for node in fringe
do (if
(< (evaluate-node-g node) resultDist)
(setf result node)
)
do (if
(< (evaluate-node-g node) resultDist)
(setf resultDist (evaluate-node-g node))
)
)
result
)
)
(defun print-node (node)
(print (format nil "City: ~D" (string (city-name (node-city node)))))
(print (format nil "Parent: ~D" (string (city-name (node-city (node-parent node))))))
(print (format nil "Children: "))
(loop for ch in (node-children node)
do (print (format nil "~D" (city-name (node-city ch))))
)
(print (format nil "Path: ~S" (node-path node)))
(print (format nil "Cost: ~D" (node-cost node)))
)
(defun expand-node (node)
(let (result)
;(print "test a")
(setf (city-visited (node-city node)) t)
;(print "test b")
(loop for nei in (city-neighbors (node-city node))
do (print "howdy")
do (setf tn (make-node
:city (car nei)
:parent node
:children nil
:path (append (node-path node) (city-name (car nei)))
:cost (+ (node-cost node) (cadr nei))
)
)
do(print-node tn)
do (if (not (city-visited (car nei)))
(setf result (append result tn))
)
do (if (not (city-visited (car nei)))
(print "APPENDED A CITY")
)
do (setf (node-children node) (append (node-children node) tn))
do(print "test e")
do (if (not result) (print "AAAAAAAAA"))
)
(loop for nd in result
do (print-node nd)
)
(if (not result) (print "AAAAAAAAA"))
result
)
)
(defun bfs (cname)
(let (node fringe)
(print "test 1")
(setf node (make-node
:city (get-city-from-list cname)
:parent nil
:children nil
:path (list cname)
:cost 0
))
(print "test 2")
(do
;vars
()
;condition
((equal (city-name (node-city node)) "Bucharest")
(return-from bfs "FK:LSJDF:LKDSJF:LKSD"))
;body
(print "test 3")
(setf fringe (append fringe (expand-node node)))
(print "test 4")
(setf node (evaluate-fringe fringe))
(print "test 5")
)
)
;lookup node, set as current
;expand
;append results to fringe
;evaluate fringe to get node
;check if node is goal
;if not expand
)
(bfs "Sibiu")
;BFS - choose lowest g
;expand-node - takes node, returns list of its children
;evaluate-fringe - take list of nodes, returns node to be expanded
;evaluate-node - takes node, provides g (used by evaluate-fringe)
;call expand-node
;append its results to the fringe
;call evaluate-fringe on the fringe
;check if result is goal
;if not, call expand node on it
(all-cities-from-list *acl*)
(all-cities-from-list (all-cities-from-htable *acht*))
(print (neighbors-p "Bucharest" "Fagaras"))
;(setup-cities "all-cities.lisp")
(PRINT ((LAMBDA (L1 L2 L3) (LIST (CAR L1) (CAR L2) (CAR L3))) '(TYPE PRINT DEL) '(H '(H J O) '(U J N)) '(READ SAVE LOAD (TXT)))) (DEFUN COMBINE (L1 L2 L3) (LIST (THIRD L1) (SECOND L2) (THIRD L3))) (PRINT (COMBINE '(TYPE PRINT DEL) '(H '(H J O) '(U J N)) '(READ SAVE LOAD (TXT)))) (DEFUN ISEXP (A B C) (= C (EXPT A B))) (PRINT (ISEXP 2 4 16))
(setq a #\S) (setq b #\M) (setq c #\S) (format t "~% A = B is ~a" (= a b)) (format t "~% A = B is ~a" (= a b)) ; (format t "~% A /= B is ~a" (/= a b)) ; (format t "~% A > B is ~a" (> a b)) ; (format t "~% A < B is ~a" (< a b)) ; (format t "~% A >= B is ~a" (>= a b)) ; (format t "~% A <= B is ~a" (<= a b)) ; (format t "~% Max of A and B is ~d" (max a b)) ; (format t "~% Min of A and B is ~d" (min a b))
(write (car '(a b c d e f)))
(terpri)
(write (cdr '(a b c d e f)))
(terpri)
(write (cons 'a '(b c)))
(terpri)
(write (list 'a '(b c) '(e f)))
(terpri)
(write (append '(b c) '(e f) '(p q) '() '(g)))
(terpri)
(write (last '(a b c d (e f))))
(terpri)
(write (reverse '(a b c d (e f))))
(write (member 'a '(b c)))
(terpri)
(write (member 'a '(a b c)))
(terpri)
(if (member 'a '(a b c))
(write "a is member")
)
(defvar SIZES (list "Small" "Medium" "Large"))
(if (member "Small" SIZES)
(write "a is member")
)
We use cookies to provide and improve our services. By using our site, you consent to our Cookies Policy. Accept Learn more
