NLP with Racket - nlp

I am studying NLP with Racket and Dr. Racket.
I am working with this code:
#lang racket
(define english-1
'((Initial (1))
(Final (9))
(From 1 to 3 by NP)
(From 1 to 2 by DET)
(From 2 to 3 by N)
(From 3 to 4 by BV)
(From 4 to 5 by ADV)
(From 4 to 5 by |#|)
(From 5 to 6 by DET)
(From 5 to 7 by DET)
(From 5 to 8 by |#|)
(From 6 to 7 by ADJ)
(From 6 to 6 by MOD)
(From 7 to 9 by N)
(From 8 to 8 by MOD)
(From 8 to 9 by ADJ)
(From 9 to 4 by CNJ)
(From 9 to 1 by CNJ)))
(define (getf x y)
(if (eq? (car x) y)
(cadr x)
(getf (cdr x) y)))
(define (initial-nodes network)
(list-ref (assoc 'Initial network) 1))
(define (final-nodes network)
(list-ref (assoc 'Final network) 1))
(define (transitions network)
(filter (lambda (x) (eq? (car x) 'From)) network))
(define (trans-node transition)
(getf transition 'From))
(define(trans-newnode transition)
(getf transition 'to))
(define (trans-label transition)
(getf transition 'by))
(define abbreviations
'((NP kim sandy lee)
(DET a the her)
(N consumer man woman)
(BV is was)
(CNJ and or)
(ADJ happy stupid)
(MOD very)
(ADV often always sometimes)))
(define (recognize network tape)
;; returns t if sucessfully recognizes tape - nil otherwise
(call/cc (lambda (return)
(define (recognize-next node tape network)
(if (and (null? tape) (member node (final-nodes network)))
(return #t) ; success
(for ([transition (transitions network)])
;; try each transition of the network
(when (equal? node (trans-node transition)) ; if it starts at the right node
(for ([newtape (recognize-move (trans-label transition) tape)])
;; try each possible new value of tape
(recognize-next (trans-newnode transition) newtape network))))))
(for ([initialnode (initial-nodes network)])
(recognize-next initialnode tape network))
null))) ; failed to recognize
(define (recognize-move label tape)
(if (or (eq? label (car tape))
(member (car tape) (assoc label abbreviations)))
(list (cdr tape))
(if (eq? label '|#|)
(list tape)
null)))
(require racket/trace)
(trace recognize-move)
(recognize-move english-1 '(hahaha))
The code seems to be mostly fine. However, I keep getting a error messaging related to the recognize-move function:
member: not a proper list: #f
And I thought I was dealing with lists... How can I solve this?

The problem is with this form:
(member (car tape) (assoc label abbreviations))
If assoc does not find anything the result is #f. (member 'anything #f) will not work. In Common Lisp false is the same as an empty list so member on false will work, but not in Scheme. You can perhaps make sure it's a list like this:
(member (car tape) (or (assoc label abbreviations) '()))

This is code translated from Common Lisp. In CL, nil is false and is also the empty list, (). In Racket, #f is false and is not the same as (). assoc wants to return false if it does not find a match: because of the way CL puns on false and the empty list, this means that (member ... (assoc ...)) will always work. In Racket it won't: you need to check to see if assoc failed to find a match.

Related

Trying to get a Scheme Depth-First or Breadth-First Search Currying function to work

I'm new here, and I need help with a function that I'm writing in scheme.
Basically, it involves a search function that can work for either Breadth-First search or Depth-First Search. I think I got the Depth-First-Merge and Breadth-First Merge to work.
However, the problem is to modify the main Search to work as a "currying function" so that when algorithm-specific merge procedures (such as the depth-first-merge or the breadth-first-merge) are passed in as arguments, the search uses that specific type of search. The return
There's two files I have with it. Coins is okay, but search needs fixed. How do I modify the search function here to work as a curried version?
Here's my codes below. first one for search.ss. I made a search2 as an early attempt, but it didn't work. I need to make either search or search2 work as the curried search, (then delete the other). I'm not sure, but I think the merges and two searches are working.
;;;
;;; SEARCH:
;;; -- Non-curried version of generic search algorithm
;;; -- Can be customized for depth-first and breadth-first search
;;; -- You must convert it to a curried version so that
;;; - the function accepts 1 algorithm specific parameter and returns a function
;;; - that accepts 3 problem-specific parameters and returns a function
;;; - that accepths 1 instance specific parameter and performs the search
;;; -- The 5 parameters are described below
;;;
;;; Input:
;;; merge-queue
;;; -- algorithm specific
;;; -- procedure that takes a list of new paths and a queue
;;; and returns a new queue
;;; extend
;;; -- problem-specific
;;; -- procedure that takes a state and a list of visited states,
;;; and returns a list of states that are reachable in one move
;;; from the given state
;;; goal?
;;; -- problem-specific
;;; -- predicate that takes a state and returns true if the
;;; state is a goal state, false otherwise
;;; print-path
;;; -- problem-specific
;;; -- procedure that takes a state and prints out a state nicely
;;; init-state
;;; -- problem instance-specific
;;; -- an initial state to start the search from
;;;
;;; OUTPUT:
;;; -- When succeeded, a path from the initial state to a goal state
;;; -- When failed, #f
;;;
;;Either this or search2 needs to be rewritten into a curried version
;;To accept either depth-first-merge or breadth-first merge as merge procedures into merge-queue
(define search
(lambda (merge-queue init-config extend goal? print-state)
(letrec
((helper
(lambda (queue)
(newline)
(for-each
(lambda (p) (print-path p print-state))
queue)
(cond ((null? queue) #f)
((goal? (caar queue))
(print-state (caar queue))
(newline)
(let ((ans (reverse (car queue))))
(for-each (lambda (x) (print-state x) (newline)) ans)
ans))
(else
(let ((successors (extend (caar queue))))
(print-state (caar queue)) (newline)
(cond ((null? successors)
(helper (cdr queue)))
(else
(for-each (lambda (x) (print-state x) (newline))
successors)
(helper
(merge-queue (cdr queue)
(extend-path successors (car queue))))))))))))
(helper
(list (list (config->state init-config ))))))
(define search2
(lambda (merge-queue extend goal? print-path init-state)
(letrec
((search-helper
(lambda (queue visited)
(cond
((null? queue) #f)
((goal? (caar queue))
(begin
(print-path (car queue))
(car queue)))
(else
(let ((successors (extend (caar queue) visited)))
(cond
((null? successors)
(search-helper (cdr queue) visited))
(else
(let ((new-paths (extend-path successors (car queue))))
(search-helper
(merge-queue queue new-paths)
(cond
(merge-queue))
(append successors visited)))))))))))
(search-helper
(list (list init-state)) ; initial queue
(list init-state))))) ; initial visited
(define extend-path
(lambda (successors path)
(if (null? successors)
'()
(cons (cons (car successors) path)
(extend-path (cdr successors) path)))))
;; merge new extended paths to queue for depth first search
;; - uncomment and define your merge for depth first search
(define depth-first-merge
(lambda (queue paths)
(append! paths queue)))
;; merge new extended paths to queue for breadth first search
;; - uncomment and define your merge for breadth first search
(define breadth-first-merge
(lambda (queue paths)
(append! queue paths)))
;; customize the generic search for depth first search
;; - uncomment and define your depth-first-search in terms of your
;; curried version of search and depth-first-merge
;; Curry Methods are helpful to this.
(define depth-first-search (search depth-first-merge))
(lambda (extend goal? print-path)
(search (depth-first-merge extend goal? print-path))))
;; customize the generic search for breadth first search
;; - uncomment and define your breadth-first-search in terms of your
;; curried version of search and breadth-first-merge
(define breadth-first-search (search breadth-first-merge))
(lambda (extend goal? print-path)
(search (breadth-first-merge extend goal? print-path))))
And this is the Coins file code that is used to compliment the search code. They are in separate files and it loads search.ss (the above one) to work.
;; load algorithm specific code for search
(load "search.ss")
;;; Problem specific code for solving the old British coin problems
;;; using the curried version of the simple search procedure.
;;; The old British coin problem was discussed in the lecture.
;;;
;;; To solve the problem, load this file and run
;;; (coin-depth-first amount)
;;; or
;;; (coin-breadth-first amount)
;;; where, amount is replaced with some number, e.g., 48.
;;;
;;; Here, a state is represented as follows:
;;; (amount (coin1 coin2 ...))
;;;
;;; The car of the state represents how much change you need to pay further.
;;; The cadr of the state represents the combination of coins you used
;;; to pay so far. For example,
;;; (48 ())
;;; is the initial state for the amount of 48 cents and
;;; (0 (24 24)
;;; can be one of the goal states using two 24-cent coins.
;; There are 7 kinds of old British coins
(define old-british-coins '(120 30 24 12 6 3 1))
;; Or, you can do the same for US coins
(define us-coins '(100 50 25 10 5 1))
;; Here, we will do the old British coins
(define *coins* old-british-coins)
;; Is a state the goal state?
(define goal?
(lambda (state)
(zero? (car state))))
;; returns children of a state
(define extend
(lambda (state visited)
(let ((coins (applicable-coins state visited *coins*)))
(map
(lambda (coin)
(list (- (car state) coin)
(append (cadr state) (list coin))))
coins))))
;; find all applicable coins from a state
(define applicable-coins
(lambda (state visited coins)
(cond
((null? coins) '())
((<= (car coins) (car state))
(if (visited? state visited (car coins))
(applicable-coins state visited (cdr coins))
(cons (car coins) (applicable-coins state visited (cdr coins)))))
(else (applicable-coins state visited (cdr coins))))))
;; see if a state has been visited before
(define visited?
(lambda (state visited coin)
(cond
((null? visited) #f)
((= (- (car state) coin) (caar visited)) #t)
(else (visited? state (cdr visited) coin)))))
;; pretty-print a state
(define pretty-print-path
(lambda (path)
(pretty-print-state (car path))))
(define pretty-print-state
(lambda (state)
(let ((change (car state))
(coins (cadr state))
(total (apply + (cadr state))))
(printf
"===> Total of ~a paid with ~a, with remainder of ~a <===~%"
total coins change))))
;; customize the generic depth-first-search for coin problem
(define coin-depth-first-search
(depth-first-search extend goal? pretty-print-path))
;; instance of a coin problem using depth-first search
(define coin-depth-first
(lambda (amount)
(coin-depth-first-search (list amount '()))))
;; customize the generic breadth-first-search for coin problem
(define coin-breadth-first-search
(breadth-first-search extend goal? pretty-print-path))
;; instance of a coin problem with breadth-first search
(define coin-breadth-first
(lambda (amount)
(coin-breadth-first-search (list amount '()))))
Can someone please help me? I think all I need to get it to work is to find out how to make the search or search2 code become a curried version.
To curry a function means to redefine it in such a way that it takes a number of parameters less than the current definition and returns a new function that takes the rest of the parameters and perform the work of the first one. For instance, you can curry the following two-parameters summing function:
(define add
(lambda (a b)
(+ a b)))
(add 7 10) ;; => 17
in the following way:
(define add-to
(lambda (a)
(lambda (b)
(+ a b))))
((add-to 7) 10) ;; => 17
(define add-to-7 (add-to 7)) ;; we give a name to the function that add 7 to its argument
(add-to-7 8) ;; => 15
(add-to-7 9) ;; => 16
So, to transform the search2 function (you must extend that function since its last parameter is the problem instance specific one):
(define search2
(lambda (merge-queue extend goal? print-path init-state)
...body of search2...
as required, you could simply write something like this:
(define search2
(lambda (merge-queue)
(lambda (extend goal? print-path)
(lambda (init-state)
...body of search2...
and then, calling it with the correct number of parameters, you could obtain “partial” functions to be called later. For instance you can define a generic depth first search as:
(define depth-first-search (search2 depth-first-merge))
then you can define the depth first search specialized for the coin problem, given appropriate definitions for the coin functions:
(define coin-depth-first (depth-first-search coin-extend coin-goal? coin-print-path))
and finally you can call it with a certain amount to solve the problem:
(coin-depth-first 100)

"set! not an identifier" in Scheme

I am trying to modify the cdr of the car of an element of a list using set!, but I am getting an error: "set! not an identifier". Can anyone explain to me why this is happening? I am starting to work with objects by the way.
#lang racket
(define (multiset)
(let ((main-list '()))
(define (empty)
(eq? main-list '()))
(define (insert x)
(cond ((empty)
(set! main-list (cons (cons x 1) main-list)))
((= (car (car main-list)) x)
(begin (set! (cdr (car main-list))
(+ 1 (cdr (car main-list))))))
(else (cdr main-list))))
A multiset is represented as a list of pairs. For example, if I had a list '(1 1 1 2 2 2), the multiset representation would be '((1.3)(2.3))
The syntax of set! is
(set! <identifier> <expression>)
which is to say that the first form must be a symbol. In your code you are using:
(cdr (car main-list))
as the 'identifier' - hence the error.
Perhaps your background is CommonLisp and you are expecting set! to behave like setf? In Scheme there are separate functions for setting the 'car' and 'cdr' of a pair. Use set-car! and set-cdr!
> (define pair (cons 'car 'cdr))
> pair
(car . cdr)
> (set-car! pair 'foo)
> pair
(foo . cdr)
> (set-cdr! pair 'bar)
> pair
(foo . bar)
In R6RS (and probably R7RS) set-car! and set-cdr! can be found in the (rnrs mutable-pairs) library
GoZoner has given you the right explanation, but it is perfectly possible (and desirable) do avoid set! procedures. Here's an example of a procedure having the same result:
(define (rle lst)
(define (newpair c l res)
(if (> l 0) (cons (cons c l) res) res))
(let loop ((lst lst) (c #f) (l 0) (res '()))
(if (null? lst)
(reverse (newpair c l res))
(let ((n (car lst)))
(if (equal? c n)
(loop (cdr lst) c (add1 l) res)
(loop (cdr lst) n 1 (newpair c l res)))))))
such as
(rle '(1 1 1 2 2 2))
=> '((1 . 3) (2 . 3))

Tail call optimization in Racket

I was doing SICP exercise 2.28 and stumbled upon a strange behaviour of the following code:
(define (fringe tree)
(cond
((null? tree) '())
((not (pair? tree)) (list tree))
(else (append (fringe (car tree)) (fringe (cdr tree))))))
(define (fringe-tail tree)
(define (fringe-iter tree result)
(cond
((null? tree) result)
((not (pair? tree)) (list tree))
(else (fringe-iter (cdr tree) (append result (fringe-tail (car tree)))))))
(fringe-iter tree '()))
(define x (make-list (expt 10 4) 4))
(time (fringe x))
(time (fringe-tail x))
Ordinary fringe runs much faster than its iterative version fringe-tail:
cpu time: 4 real time: 2 gc time: 0
vs.
cpu time: 1063 real time: 1071 gc time: 191
It looks like fringe was optimized into loop and avoids any allocations, while fringe-tail runs much slower and spends time creating and destroying objects.
Can anyone explain this to me?
(Just in case I'm using racket 5.2.1)
If you replace the last clause with:
(else (fringe-iter (cdr tree) (append (fringe-tail (car tree)) result)))
then they run at the same speed for that input, and the tail-recursive version is faster for larger input.
The problem is that you're appending the much longer list for the cdr on to the front, which traverses and allocates much more than the naive version, which appends the fringe of the car on to the front.
The given code has applications in non-tail position, so the function is not iterative, despite its name. :)
Try this:
(define (fringe-tail tree)
(define (iter tree k)
(cond
[(null? tree)
(k '())]
[(not (pair? tree))
(k (list tree))]
[else
(iter (car tree)
(lambda (v1)
(iter (cdr tree)
(lambda (v2)
(k (append v1 v2))))))]))
(iter tree (lambda (a-fringe) a-fringe)))
However, it still uses append which is as expensive as the length of its first argument. Certain degenerate inputs into fringe and fringe-tail will cause a lot of computational suffering.
Let's give an example of such degenerate inputs:
(define (build-evil-struct n)
(if (= n 0)
(list 0)
(list (list (build-evil-struct (sub1 n)))
(build-evil-struct (sub1 n))
(list n))))
(define evil-struct (build-evil-struct 20))
When applied to both fringe and fringe-iter, you'll see very bad performance: I observe seconds of compute time on my own system for fringe and fringe-tail. These tests were run under DrRacket with debugging disabled. If you enable debugging, your numbers will be significantly different.
> (time (void (fringe evil-struct)))
cpu time: 2600 real time: 2602 gc time: 1212
> (time (void (fringe-tail evil-struct)))
cpu time: 4156 real time: 4155 gc time: 2740
With both of these, the use of append is what makes these susceptible to certain degenerate inputs. If we write an accumulating version of fringe, we can eliminate that cost, since we then get to use the constant-time cons operation:
(define (fringe/acc tree)
(define (iter tree acc)
(cond [(null? tree)
acc]
[(not (pair? tree))
(cons tree acc)]
[else
(iter (car tree) (iter (cdr tree) acc))]))
(iter tree '()))
Let's look at the performance of fringe/acc on this structure:
> (time (void (fringe/acc evil-struct)))
cpu time: 272 real time: 274 gc time: 92
Much better! And it's a straightforward matter to turn all the calls here to tail calls.
(define (fringe/acc/tail tree)
(define (iter tree acc k)
(cond [(null? tree)
(k acc)]
[(not (pair? tree))
(k (cons tree acc))]
[else
(iter (cdr tree) acc
(lambda (v1)
(iter (car tree) v1 k)))]))
(iter tree '() (lambda (v) v)))
> (time (void (fringe/acc/tail evil-struct)))
cpu time: 488 real time: 488 gc time: 280
Racket's implementation of the stack is, in this particular case, a bit faster than our reified stack we're representing in the continuations, so fringe/acc is faster than fringe/acc/tail. Still, both of these are significantly better than fringe because they avoid append.
All this being said: this function is already built-into Racket as the flatten function! So you might as well just use that if you don't want to reinvent the wheel. :)

Scheme - dynamic scope and infinte loop

I read a book about scheme, and it has the next example:
(define map
(lambda (f s)
(if (null? s)
'()
(cons (f (car s))
(map f (cdr s)))))
(map (lambda (s)
(set! s '(1 2 3 4))
'hello)
'(a b c d))
It say that in dynamic scope, we will enter to infinite loop. But why? As I understood, After we apply the application, we arrive to map with
f = (lambda (s)
(set! s '(1 2 3 4))
'hello)
and s= '(a b c d). Now, for the first run, we will apply f on (car '(a b c d):
((lambda (s)
(set! s '(1 2 3 4))
'hello)
(car '(a b c d)))
And now, It change a to be (1 2 3 4). And so on.. Where is the loop here?
I think what the author means is that after f (car s) executes, the value of s will be '(1 2 3 4), so the value of (cdr s) will be '(2 3 4), so you'll call (map f '(2 3 4)) every time ad infinitum.
However I do not think this is an accurate depiction of dynamic scoping. Since s is a parameter to the lambda (and thus not a free variable), only that parameter should be affected by the set! and the s of the map function should be unaffected. So there should be no infinite loop - whether you're using dynamic scoping or not. And if I translate the code to elisp (which is dynamically scoped), the code does in fact not cause an infinite loop. So I'd say your book is wrong in saying there'd be an infinite loop using dynamic scoping.

Does Lisp have something like Haskell's takeWhile function?

I'm new to Common Lisp. In Haskell, you can do a little something like this:
Prelude> takeWhile (<= 10) [k | k <- [1..]]
[1,2,3,4,5,6,7,8,9,10]
Is this possible in Lisp? Not necessarily with an infinite list, but with any list.
You could use LOOP:
(setq *l1* (loop for x from 1 to 100 collect x))
(loop for x in *l1* while (<= x 10) collect x)
If you really need it as a separate function:
(defun take-while (pred list)
(loop for x in list
while (funcall pred x)
collect x))
And here we are:
T1> (take-while (lambda (x) (<= x 10)) *l1*)
(1 2 3 4 5 6 7 8 9 10)
But if we compare:
(loop for x in *l1* while (<= x 10) collect x)
(take-while (lambda (x) (<= x 10)) *l1*)
I think I would just stick with loop.
For infinite sequences, you could take a look at Series:
T1> (setq *print-length* 20)
20
T1> (setq *l1* (scan-range :from 1))
#Z(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 ...)
T1> (until-if (lambda (x) (> x 10)) *l1*)
#Z(1 2 3 4 5 6 7 8 9 10)
This should do...
(defun take-while (list test)
(and list (funcall test (car list))
(cons (car list) (take-while (cdr list) test))))
(take-while '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (lambda (x) (< x 10)))
--> (1 2 3 4 5 6 7 8 9)
However this "natural" implementation is not tail-recursive and could crash for big lists.
An explicit push-nreverse approach (a common pattern) could be
(defun take-while (list test)
(do ((res nil))
((or (null list) (not (funcall test (car list))))
(nreverse res))
(push (car list) res)
(setf list (cdr list))))
A recursive (but tail-recursive, therefore probably ok with most CL implementations) could IMO be the following:
(defun take-while (list test)
(labels ((rec (res x)
(if (and x (funcall test (car x)))
(rec (cons (car x) res) (cdr x))
(nreverse res))))
(rec nil list)))
Note that however it's not guaranteed that a common lisp implementation will handle tail-call optimizations.
The CL-LAZY library implements lazy calling for Common Lisp and provides a take-while function that is laziness aware. You can install it with Quicklisp and try it out.
Some languages provide a Haskell-style list API as 3rd party libraries, with or without support for infinite streams.
Some examples:
Clojure's sequences: take-while
Scala has something
Remember that takeWhile is relatively easy to implement over a sequence, and is given in Haskell as:
takeWhile _ [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
You can have a lazy evaluation in common lisp using closures (from Paul Graham's On Lisp):
(defun lazy-right-fold (comb &optional base)
"Lazy right fold on lists."
(labels ((rec (lst)
(if (null lst)
base
(funcall comb
(car lst)
#'(lambda () (rec (cdr lst)))))))
#'rec))
Then, take-while becomes:
(defun take-while (pred lst)
(lazy-right-fold #'(lambda (x f) (
(if (test x)
(cons x (funcall f))
(funcall f)))
nil))

Resources