Scheme Find all possible paths for an undirected graph - graph

I am having problem to print out all the possible paths. Currently I am only able to print out one path, and if (path-demo "J" "I"), the program will shown this error mcdr: expects argument of type <mutable-pair>; given #f
(define net
'(("A" "B")
("B" "A" "C")
("C" "B" "D")
("D" "C" "E" "F")
("F" "I" "D")
("I" "F")
("E" "D" "J")
("J" "E" "G")
("G" "J" "H")))
(define (path-demo start finish)
(for-each (lambda (x) (display x) (display " "))
(cons "Route:" (shortest-path start finish net))))
(define (shortest-path start end net)
(bfs end (list (list start)) net))
;; Breadth-first search
(define (bfs end queue net)
(display queue) (newline) (newline) ; entertainment
(if (null? queue)
'()
(let ((path (car queue)))
(let ((node (car path)))
(if (equal? node end) ;; Graham used CL eql
(reverse path)
(bfs end
(append (cdr queue)
(new-paths path node net))
net))))))
(define (new-paths path node net)
(map (lambda (n) (cons n path)) (cdr (assoc node net))))
;;
(path-demo "J" "I")

In your definition of net you have forgotten to list the nodes to which H is connected.
When the error occurs node and net have the following values:
node: H
net: ((A B) (B A C) (C B D) (D C E F) (F I D) (I F) (E D J)
(J E G) (G J H)))
Thus
(assoc node net))
will return #f because H has no associations in net.
And this leads to the error from cdr:
cdr: expects argument of type <pair>; given #f

It is likely that the following returns #f:
(cdr (assoc node net))
Regarding comment (for formatting):
(define (new-paths path node net)
(write node)
(newline)
(map (lambda (n) (cons n path)) (cdr (assoc node net))))

Related

Replaces occurrences in a list - Racket

I am writing a function called ptyper that takes a nested list, nl. This function replaces all occurrences of a number with n and all occurrences of a symbol with s. This is what I have now:
(define (ptyper nl) (cond
((null? nl) '())
((list? nl)
(let ((ls (car nl)))
(list (ptyper ls))))
((number? (car nl))
(cons "n" (cdr nl)))
((symbol? (car nl))
(cons "s" (cdr nl)))
(else
(cons (car nl) (cdr nl)))))
I ran this test (ptyper '(2 (abc () "abc"))) but received an error that their was a contract violation. I'm not exactly sure what I'm doing wrong so if could use some help. Thanks!
Here is a possible solution with one function:
(define (ptyper nl)
(cond
((null? nl) '()) ; if the argument is an empty list, return the empty list
((list? nl) ; if the argument is a list, then
(let* ((c (car nl)) ; get its first element
(nc (cond ((number? c) "n") ; transform it for numbers
((symbol? c) "s") ; and symbols
((list? c) (ptyper c)) ; if a list recur over it
(else c)))) ; otherwise (e.g. a string) return as it is
(cons nc (ptyper (cdr nl))))) ; recursive call on the rest of the list
(else nl))) ; this should never happen for the specification,
; return the parameter or cause an error
Note that the error in your case is caused by the recursive call. When the function is called on an atom, for instance 2, first it checks for null and list?, and those checks returns false. Then it checks for (number (car nl)), but nl is equal to 2 and so car fails.
Here is a data definition for an S-expression, this models your data.
; An S-expr is one of:
; – Atom
; – SL
; An SL is one of:
; – '()
; – (cons S-expr SL)
; An Atom is one of:
; – Number
; – String
; – Symbol
We have predicates for every kind of data except Atom, so we make atom?:
;; Any -> Boolean
;; is the x an atom?
(define (atom? x)
(not (list? x)))
We follow the structure of the data to build "templates" for our functions:
(define (func sexp)
(cond
[(atom? sexp) (func-atom sexp)]
[else (func-sl sexp)]))
(define (func-sl sl)
(cond
[(empty? sl) ...]
[else (... (func (first sl)) ... (func-sl (rest sl)) ...)]))
(define (func-atom at)
(cond
[(number? at) ...]
[(string? at) ...]
[(symbol? at) ...]))
We fill in the gaps:
; Atom -> String
(define (subs-atom at)
(cond
[(number? at) "n"]
[(string? at) at]
[(symbol? at) "s"]))
; SL -> SL
(define (subs-sl sl)
(cond
[(empty? sl) sl]
[else (cons (subs-sexp (first sl))
(subs-sexp (rest sl)))]))
; S-exp -> S-exp
(define (subs-sexp sexp)
(cond
[(atom? sexp) (subs-atom sexp)]
[else (subs-sl sexp)]))
Using the interface for ptyper:
(define (ptyper nl)
(subs-sexp nl))
(ptyper '(2 (abc () "abc")))
; => '("n" ("s" () "abc"))

Counting occurrence of a word in LISP lists

So I have to count the occurrence of a word(or character, to be more specific) in a list in lisp. For example, the input:
(freq 'c '(a c c c c (c c c e)))
should produce a count of 7, since there are 7 c's in the list argument. The code I have is the following but it does not work. I can count the 4 c's that are base elements and the 3 c's that are in the sublist, but I dont know how to add them together. Also, I'm using only primitive data types.
(defun freq (a L)
(cond
((null L) 0)
((listp (car L)) ( (freq a (car L))) ((freq a (cdr L))))
((eq a (car L))(+ 1 (freq a (cdr L))))
(t ((freq a (cdr L))))))
If it's a character then it's should be written with this prefix -> #\
and the sequence would be a string so there is no need recursion here.
(count #\c "(a c c c c (c c c e))") => 7
What you're dealing with in your example is symbol (with a single quote) through a list which contains other symbols or cons. So if you need to count all the same symbol you could write something like that :
(defparameter *nb* 0)
(defun look-deeper (test seq)
(loop for i in seq do
(compare test i)))
(defun compare (test item)
(let ((type (type-of item)))
(case type
(symbol (when (eql test item) (incf *nb*)))
(cons (look-deeper test item)))))
(look-deeper 'c '(a c c c c (c c c e))) => NIL
*nb* => 7
Or something better..
(defun count-occurences (obj lst)
(let ((acc 0))
(labels ((test (obj-2)
(eq obj obj-2)))
(dolist (x lst)
(if (consp x)
(let ((sample (remove-if-not #'test x)))
(if sample
(incf acc (length sample))))
(if (eq x obj)
(incf acc 1)))))
acc))
We could create a function that takes an obj to test and a lst as the argument and create a local accumulator to keep track of how many times the obj occurs in the list. Then we could create a local function that tests to see if the obj we pass to it is eq to the obj passed as an argument to the global function (also note that if you are working with strings you might want to use string-equal or equal because eq will not work since they are not the same object, but eq will work with symbols which you used in your example). We can then iterate through the list, and if the element in the list is a cons we can use remove-if-not to remove any element that doesn't pass our test (is not eq to the obj), and based on the length of the list increment our accumulator accordingly. If it is not a cons and is eq to our obj we will also increment the accumulator, then we can return the value of our accumulator.
And if we test it:
CL-USER> (count-occurences 'c '(a c c c c (c c c)))
7
Your logic is actually correct, there are just some small mis-parenthesis problems in your code. The only change you need for your code to work is to change you listp and t clauses from
((listp (car L)) ( (freq a (car L))) ((freq a (cdr L))))
into
((listp (car L)) (+ (freq a (car L)) (freq a (cdr L))))
and from
(t ((freq a (cdr L))))
into
(t (freq a (cdr L)))
Then evaluating your function works just as you expect:
(defun freq (a L)
(cond
((null L) 0)
((listp (car L)) (+ (freq a (car L)) (freq a (cdr L))))
((eq a (car L))(+ 1 (freq a (cdr L))))
(t (freq a (cdr L)))))
(freq 'c '((a (c f c)) c c c (c c (d c f (c 8 c) c) e))) ; => 11 (4 bits, #xB, #o13, #b1011)

Racket - outputting in numerical form the placement of a string within a list (from left to right)

I've been tasked with creating a function that tells the placement in numerical form of a string within a list (from left to right), so that:
(position "a" '("a" "b" "c" "d" "e"))
returns 1
(position "b" '("a" "b" "c" "d" "e"))
returns 2 and
(position "z" '("a" "b" "c" "d" "e"))
returns #f
I've written it as such:
(define (position x L)
(if (pair? L)
(if (equal? x (car L))
1
(+ 1 (position x (cdr L)))
)
#f)
)
Unfortunately,
(position "z" '("a" "b" "c" "d" "e"))
Doesn't work at all since it's trying to add #f to a number. Is there any way out of this pickle?
Your answer is correct, but I'll suggest a different approach: by using a named let for implementing tail recursion we'll obtain a more efficient solution. Also notice how using cond (instead of nesting ifs) simplifies things:
(define (position x L)
(let loop ((L L) (acc 1))
(cond ((null? L) #f)
((equal? x (car L)) acc)
(else (loop (cdr L) (add1 acc))))))
Also, in the SRFI-1 library we can find the function list-index which almost returns what you want, we just have to add one to the result to convert it to a 1-based index:
(require srfi/1)
(define (position x L)
(cond ((list-index (curry equal? x) L) => add1)
(else #f)))
I fixed it by doing:
(define (position x L)
(if (pair? L)
(if (equal? x (car L))
1
(let ((p-cdr-L (position x (cdr L))))
(if p-cdr-L
(+ 1 p-cdr-L)
#f)))
#f))

Graph all child nodes common lisp

I need to find all nodes that are children of selected node. Graph is created like this:
(setq graf1 '((A(B C)) (B(D E)) (C (F G )) (D (H)) (E(I)) (F(J)) (G(J)) (H()) (I(J)) (J())))
So, all children from node B are (on first level) D,E, on 2nd H,I, third J.
Here's the code for finding first level children, but as i'm begineer in lisp i cant make it work for other ones.
(defun sledG (cvor graf obradjeni)
(cond ((null graf) '())
((equal (caar graf) cvor)
(dodaj (cadar graf) obradjeni))
(t(sledG cvor (cdr graf) obradjeni)))
(defun dodaj (potomci obradjeni)
(cond ((null potomci) '())
((member (car potomci) obradjeni)
(dodaj (cdr potomci) obradjeni )
(t(cons (car potomci)
(dodaj (cdr potomci) obradjeni) ))))
(setq graf1 '((A(B C)) (B(D E)) (C (F G )) (D (H)) (E(I)) (F(J)) (G(J)) (H()) (I(J)) (J())))
Using alexandria package:
(defvar *graf*
'((a (b c)) (b (d e)) (c (f g)) (d (h)) (e (i)) (f (j)) (g (j)) (h nil) (i (j)) (j nil)))
(defun descendants (tree label)
(let ((generation
(mapcan #'cadr
(remove-if-not
(alexandria:compose (alexandria:curry #'eql label) #'car)
tree))))
(append generation (mapcan (alexandria:curry #'descendants tree) generation))))
;; (D E H I J)
I believe, this is what you wanted to do. This will work for acyclic graphs, but it will recur "forever", if you have a cycle in it. If you wanted to add depth counter, you could add it as one more argument to descendants or in the last mapcan transform the resulting list by inserting the depth counter.
With depth included:
(defun descendants (tree label)
(labels ((%descendants (depth label)
(let ((generation
(mapcan #'cadr
(remove-if-not
(alexandria:compose
(alexandria:curry #'eql label) #'car)
tree))))
(append (mapcar (alexandria:compose
#'nreverse
(alexandria:curry #'list depth))
generation)
(mapcan (alexandria:curry #'%descendants (1+ depth))
generation)))))
(%descendants 0 label)))
;; ((D 0) (E 0) (H 1) (I 1) (J 2))
As I read it, the graph is a directed graph. So to find the children (directed edges) of the graph (in the example),
(defun children (node graph) (second (assoc node graph)))
then
(children 'b graf1) ; with graf1 from the OP
returns (D E). All you have to do then is to loop over the children, something like (very quick and dirty)
(defun all-children (node graph)
(let ((c (children node graph)))
(if (null c) nil
(union c (loop for x in c appending (all-children x graph))))))
This returns (J I H D E) as children of B.

LISP - Breadth First Search

I have an implementation of BFS I got elsewhere and modified slightly, but I am having problems with its input.
It takes a graph, and will take it as '((a b c) (b c) (c d))
But my input I am giving it is a weighted graph... I know it's not useful for the BFS, but I use the weights farther down the line later. This input looks like
'(
(a (b 3) (c 1))
(b (a 3) (d 1))
(c (a 1) (d2) (e 2))
)
And so on.
My code:
(defun shortest-path (start end net)
(BFS end (list (list start)) net))
(defun BFS (end queue net)
(if (null queue)
nil
(expand-queue end (car queue) (cdr queue) net)))
(defun expand-queue (end path queue net)
(let ((node (car path)))
(if (eql node end)
(reverse path)
(BFS end
(append queue
(new-paths path node net))
net))))
(defun new-paths (path node net)
(mapcar #'(lambda (n)
(cons n path))
(cdr (assoc node net))))
I'm just not sure where I need to most likely modify it to accept the new style list, or make a help function to format it correctly?
You need to specify what the list that represents your graph means. Currently you have only given an example list.
When the graph has a syntax like:
graph = (node*)
node = (name nextnodename*)
name = SYMBOL
nextnodename = SYMBOL
Then a transformation function might be:
(defun convert-graph (graph)
(mapcar (lambda (node)
(destructuring-bind (name . nodes) node
(cons name (mapcar #'first nodes))))
graph))
or if you might need other extraction functions:
(defun convert-graph (graph &key (key #'first))
(mapcar (lambda (node)
(destructuring-bind (name . nodes) node
(cons name (mapcar key nodes))))
graph))
Example:
(convert-graph '((a (b 3) (c 1))
(b (a 3) (d 1))
(c (a 1) (d 2) (e 2)))
:key #'first)
((A B C) (B A D) (C A D E))
Now you might need to remove duplicate links. But this depends on the syntax and semantics of your graph description.

Resources