I found a general memoization from here, which makes fib much faster by
(define (memoize fn)
(let ((cache (make-hash)))
(λ arg (hash-ref! cache arg (thunk (apply fn arg))))))
(define fib
(memoize
(lambda (n)
(if (< n 2) n (+ (fib (sub1 n)) (fib (- n 2)))))))
I tried to implement the interleaving string question in Racket in natural recursion as
(define (is-interleave-rec s1 s2 s3)
(if (eq? (+ (string-length s1) (string-length s2))
(string-length s3))
(aux-rec s1 0 s2 0 s3 0)
#f))
(define (aux-rec s1 p1 s2 p2 s3 p3)
(cond
[(eq? p3 (string-length s3)) #t]
[(eq? p1 (string-length s1))
(equal? (substring s2 p2) (substring s3 p3))]
[(eq? p2 (string-length s2))
(equal? (substring s1 p1) (substring s3 p3))]
[(and (eq? (string-ref s1 p1) (string-ref s3 p3))
(eq? (string-ref s2 p2) (string-ref s3 p3)))
(or (aux-rec s1 (add1 p1) s2 p2 s3 (add1 p3))
(aux-rec s1 p1 s2 (add1 p2) s3 (add1 p3)))]
[(eq? (string-ref s1 p1) (string-ref s3 p3))
(aux-rec s1 (add1 p1) s2 p2 s3 (add1 p3))]
[(eq? (string-ref s2 p2) (string-ref s3 p3))
(aux-rec s1 p1 s2 (add1 p2) s3 (add1 p3))]
[else #f]))
And then a memoization version
(define (is-interleave-mem s1 s2 s3)
(if (eq? (+ (string-length s1) (string-length s2))
(string-length s3))
(aux-mem s1 0 s2 0 s3 0)
#f))
(define aux-mem
(memoize
(λ (s1 p1 s2 p2 s3 p3)
(cond
[(eq? p3 (string-length s3)) #t]
[(eq? p1 (string-length s1))
(equal? (substring s2 p2) (substring s3 p3))]
[(eq? p2 (string-length s2))
(equal? (substring s1 p1) (substring s3 p3))]
[(and (eq? (string-ref s1 p1) (string-ref s3 p3))
(eq? (string-ref s2 p2) (string-ref s3 p3)))
(or (aux-mem s1 (add1 p1) s2 p2 s3 (add1 p3))
(aux-mem s1 p1 s2 (add1 p2) s3 (add1 p3)))]
[(eq? (string-ref s1 p1) (string-ref s3 p3))
(aux-mem s1 (add1 p1) s2 p2 s3 (add1 p3))]
[(eq? (string-ref s2 p2) (string-ref s3 p3))
(aux-mem s1 p1 s2 (add1 p2) s3 (add1 p3))]
[else #f]))))
To my surprise, the memoization version is slower, testing case was
(define as (make-string 10000 #\a))
(define zs (make-string 10000 #\z))
(define bs (make-string 10000 #\b))
(define az (string-append as zs))
(define abz (string-append as bs zs))
(time (is-interleave-rec az bs abz))
(time (is-interleave-mem az bs abz))
The result would be
cpu time: 4 real time: 4 gc time: 0
#t
cpu time: 5333 real time: 5348 gc time: 67
#t
I thought the reason would be there're so many parameters for the hash table, I was wondering if maybe we could improve it?
I changed the code as follows:
(define allcalls 0)
(define memcalls 0)
(define (memoize fn)
(let ((cache (make-hash)))
(λ arg
(set! allcalls (add1 allcalls))
(hash-ref! cache arg
(thunk
(set! memcalls (add1 memcalls))
(apply fn arg))))))
to track how many times aux-mem is called, and how many times it has to call the underlying procedure.
Adding a
(displayln allcalls)
(displayln memcalls)
at the end I get
cpu time: 2 real time: 2 gc time: 0
#t
cpu time: 7046 real time: 7040 gc time: 30
#t
20001
20001
meaning that aux-mem is never called twice with the same arguments.
So your memoïzation is totally ineffective (after all, the point of memoïzing is to return a result that has already been asked for and therefore computed earlier) and all it does here is adding overhead.
Related
Starting to learn LISP and wrote two simple programs, which uses functions as params.
The first:
;gnu clisp 2.49.60
(defun pf (x f123) (cond ((null x) nil)
(T (cons ( f123 (car x) ) (pf (cdr x) f123)))))
(defun f2 (x) (* x x))
(print (pf '(1 2 3 4) 'f2 ) )
The second:
(defun some1(P1 P2 x)
(if (not( = (length x) 0))
(cond
(
(or ( P1 (car x) ) ( P2 (car x)) )
(cons (car x) (some1 P1 P2 (cdr x) ))
)
(t (some1 P1 P2 (cdr x) ))
)
)
)
(print (some1 'atom 'null '( 5 1 0 (1 2) 10 a b c) ) )
The both of program aren't working. And I don't know how to fix it :(
(funcall f123 x y z) is works, so results:
;gnu clisp 2.49.60
(defun pf (x f123)
(cond ((null x) nil)
(T (cons (funcall f123 (car x))
(pf (cdr x) f123)))))
(defun f2 (x) (* x x))
(print (pf '(1 2 3 4) 'f2))
And
;gnu clisp 2.49.60
(defun eq0(x)
(if (= x 0)
t
nil))
(defun bg10(x)
(if (> x 10)
t
nil))
(defun some1 (P1 P2 x)
(if (not (= (length x) 0))
(cond
((or (funcall P1 (car x)) (funcall P2 (car x)))
(cons (car x) (some1 P1 P2 (cdr x))))
(t (some1 P1 P2 (cdr x))))))
(print (some1 'eq0 'bg10 '(5 0 0 11)))
Maybe it will be useful for someone :)
I am trying to write a racket program that computes the sum of the first n terms in a fibonacci sequence without using recursion, and only using abstract list functions (so map, builld-list, foldr, foldl). I can use helper functions.
I'm stuck on how to make a list of the fibonacci numbers without using recursion. I thought I could use a lambda function:
(lambda (lst) (+ (list-ref lst (- (length lst) 1)) (list-ref lst (- (length lst 2)))))
But I am not sure how to generate the input list/how to add this to a function.
Once I have a fibonacci sequence I know I can just use (foldl + (car lst) (cdr lst)) to find the sum.
Could anyone explain to me how to make the fibonacci sequence/give me a hint?
; This is how I figure out
#|
(1 2 3 4 (0 1))
-> (1 2 3 (1 1))
-> (1 2 (1 2))
-> (1 (2 3))
-> (3 5)
|#
(define (fib n)
(cond
[(= n 0) 0]
[(= n 1) 1]
[(> n 1)
(second
(foldr (λ (no-use ls) (list (second ls) (+ (first ls) (second ls))))
'(0 1)
(build-list (- n 1) (λ (x) x))))]))
(fib 10)
(build-list 10 fib)
Upgrade version 2
(define (fib-v2 n)
(first
(foldr (λ (no-use ls) (list (second ls) (+ (first ls) (second ls))))
'(0 1)
(build-list n (λ (x) x)))))
(build-list 10 fib-v2)
fib-seq produces a list of first n fibonacci numbers and fib-sum produces the sum of first n fibonacci numbers.
; Number -> [List-of Number]
(define (fib-seq n)
(cond [(= n 0) '()]
[(= n 1) '(0)]
[else (reverse
(for/fold ([lon '(1 0)]) ([_ (in-range (- n 2))])
(cons (apply + (take lon 2)) lon)))]))
; Number -> Number
(define (fib-sum n)
(if (= n 0) 0 (add1 (apply + (take (fib-seq n) (sub1 n))))))
Note: fib-sum is equivalent to the following recursive versions:
(define (fib0 n)
(if (< n 2) n (+ (fib0 (- n 1)) (fib0 (- n 2)))))
(define (fib1 n)
(let loop ((cnt 0) (a 0) (b 1))
(if (= n cnt) a (loop (+ cnt 1) b (+ a b)))))
(define (fib2 n (a 0) (b 1))
(if (= n 0) 0 (if (< n 2) 1 (+ a (fib2 (- n 1) b (+ a b))))))
Once I have a fibonacci sequence I know I can just use (foldl + (car lst) (cdr lst)) to find the sum.
Note that you don't have to generate an intermediate sequence to find the sum. Consider the (fast) matrix exponentiation solution:
(require math/matrix)
(define (fib3 n)
(matrix-ref (matrix-expt (matrix ([1 1] [1 0])) n) 1 0))
Testing:
(require rackunit)
(check-true
(let* ([l (build-list 20 identity)]
[fl (list fib0 fib1 fib2 fib3 fib-sum)]
[ll (make-list (length fl) l)])
(andmap (λ (x) (equal? (map fib0 l) x))
(map (λ (x y) (map x y)) fl ll))))
I am trying to write a Scheme macro that loops over the prime numbers. Here is a simple version of the macro:
(define-syntax do-primes
(syntax-rules ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
((or test (< hi p)) res ...) exp ...))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...) exp ...))
((do-primes (p) (binding ...) (test res ...) exp ...)
(do ((p 2 (next-prime p)) binding ...) (test res ...) exp ...))))
The do-primes macro expands to a do with three possible syntaxes: if the first argument to do-primes is (p lo hi) then the do loops over the primes from lo to hi unless iteration is stopped early by the termination clause, if the first argument to do-primes is (p lo) then the do loops over the primes starting from lo and continuing until the termination clause stops the iteration, and if the first argument to do-primes is (p) then the do loops over the primes starting from 2 and continuing until the termination clause stops the iteration. Here are some sample uses of the do-primes macro:
; these lines display the primes less than 25
(do-primes (p 2 25) () (#f) (display p) (newline))
(do-primes (p 2) () ((< 25 p)) (display p) (newline))
(do-primes (p) () ((< 25 p)) (display p) (newline))
; these lines return a list of the primes less than 25
(do-primes (p 2 25) ((ps (list) (cons p ps))) (#f (reverse ps)))
(do-primes (p 2) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
(do-primes (p) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; these lines return the sum of the primes less than 25
(do-primes (p 2 25) ((s 0 (+ s p))) (#f s))
(do-primes (p 2) ((s 0 (+ s p))) ((< 25 p) s))
(do-primes (p) ((s 0 (+ s p))) ((< 25 p) s))
What I want to do is write a version of the do-primes macro that uses a local version of the next-prime function; I want to do that because I can make the next-prime function run faster than my general-purpose next-prime function because I know the environment in which it will be called. I tried to write the macro like this:
(define-syntax do-primes
(let ()
(define (prime? n)
(if (< n 2) #f
(let loop ((f 2))
(if (< n (* f f)) #t
(if (zero? (modulo n f)) #f
(loop (+ f 1)))))))
(define (next-prime n)
(let loop ((n (+ n 1)))
(if (prime? n) n (loop (+ n 1)))))
(lambda (x) (syntax-case x ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(syntax
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
((or test (< hi p)) res ...) exp ...)))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(syntax
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...) exp ...)))
((do-primes (p) (binding ...) (test res ...) exp ...)
(syntax
(do ((p 2 (next-prime p)) binding ...) (test res ...) exp ...))))))))
(Ignore the prime? and next-prime functions, which are there only for illustration. The real version of the do-primes macro will use a segmented sieve for small primes and switch to a Baillie-Wagstaff pseudoprime test for larger primes.) But that doesn't work; I get an error message telling me that that I am trying "to reference out-of-phase identifier next-prime." I understand the problem. But my macrology wizardry is insufficient to solve it.
Can someone show me how to write the do-primes macro?
EDIT: Here is the final macro:
(define-syntax do-primes (syntax-rules () ; syntax for iterating over primes
; (do-primes (p lo hi) ((var init next) ...) (pred? result ...) expr ...)
; Macro do-primes provides syntax for iterating over primes. It expands to
; a do-loop with variable p bound in the same scope as the rest of the (var
; init next) variables, as if it were defined as (do ((p (primes lo hi) (cdr
; p)) (var init next) ...) (pred result ...) expr ...). Variables lo and hi
; are inclusive; for instance, given (p 2 11), p will take on the values 2,
; 3, 5, 7 and 11. If hi is omitted the iteration continues until stopped by
; pred?. If lo is also omitted iteration starts from 2. Some examples:
; three ways to display the primes less than 25
; (do-primes (p 2 25) () (#f) (display p) (newline))
; (do-primes (p 2) () ((< 25 p)) (display p) (newline))
; (do-primes (p) () ((< 25 p)) (display p) (newline))
; three ways to return a list of the primes less than 25
; (do-primes (p 2 25) ((ps (list) (cons p ps))) (#f (reverse ps)))
; (do-primes (p 2) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; (do-primes (p) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; three ways to return the sum of the primes less than 25
; (do-primes (p 2 25) ((s 0 (+ s p))) (#f s))
; (do-primes (p 2) ((s 0 (+ s p))) ((< 25 p) s))
; (do-primes (p) ((s 0 (+ s p))) ((< 25 p) s))
; functions to count primes and return the nth prime (from P[1] = 2)
; (define (prime-pi n) (do-primes (p) ((k 0 (+ k 1))) ((< n p) k)))
; (define (nth-prime n) (do-primes (p) ((n n (- n 1))) ((= n 1) p)))
; The algorithm used to generate primes is a segmented Sieve of Eratosthenes
; up to 2^32. For larger primes, a segmented sieve runs over the sieving
; primes up to 2^16 to produce prime candidates, then a Baillie-Wagstaff
; pseudoprimality test is performed to confirm the number is prime.
; If functions primes, expm, jacobi, strong-pseudoprime?, lucas, selfridge
; and lucas-pseudoprime? exist in the outer environment, they can be removed
; from the macro.
((do-primes (p lo hi) (binding ...) (test result ...) expr ...)
(do-primes (p lo) (binding ...) ((or test (< hi p)) result ...) expr ...))
((do-primes (pp low) (binding ...) (test result ...) expr ...)
(let* ((limit (expt 2 16)) (delta 50000) (limit2 (* limit limit))
(sieve (make-vector delta #t)) (ps #f) (qs #f) (bottom 0) (pos 0))
(define (primes n) ; sieve of eratosthenes
(let ((sieve (make-vector n #t)))
(let loop ((p 2) (ps (list)))
(cond ((= n p) (reverse ps))
((vector-ref sieve p)
(do ((i (* p p) (+ i p))) ((<= n i))
(vector-set! sieve i #f))
(loop (+ p 1) (cons p ps)))
(else (loop (+ p 1) ps))))))
(define (expm b e m) ; modular exponentiation
(let loop ((b b) (e e) (x 1))
(if (zero? e) x
(loop (modulo (* b b) m) (quotient e 2)
(if (odd? e) (modulo (* b x) m) x)))))
(define (jacobi a m) ; jacobi symbol
(let loop1 ((a (modulo a m)) (m m) (t 1))
(if (zero? a) (if (= m 1) t 0)
(let ((z (if (member (modulo m 8) (list 3 5)) -1 1)))
(let loop2 ((a a) (t t))
(if (even? a) (loop2 (/ a 2) (* t z))
(loop1 (modulo m a) a
(if (and (= (modulo a 4) 3)
(= (modulo m 4) 3))
(- t) t))))))))
(define (strong-pseudoprime? n a) ; strong pseudoprime base a
(let loop ((r 0) (s (- n 1)))
(if (even? s) (loop (+ r 1) (/ s 2))
(if (= (expm a s n) 1) #t
(let loop ((r r) (s s))
(cond ((zero? r) #f)
((= (expm a s n) (- n 1)) #t)
(else (loop (- r 1) (* s 2)))))))))
(define (lucas p q m n) ; lucas sequences u[n] and v[n] and q^n (mod m)
(define (even e o) (if (even? n) e o))
(define (mod n) (if (zero? m) n (modulo n m)))
(let ((d (- (* p p) (* 4 q))))
(let loop ((un 1) (vn p) (qn q) (n (quotient n 2))
(u (even 0 1)) (v (even 2 p)) (k (even 1 q)))
(if (zero? n) (values u v k)
(let ((u2 (mod (* un vn))) (v2 (mod (- (* vn vn) (* 2 qn))))
(q2 (mod (* qn qn))) (n2 (quotient n 2)))
(if (even? n) (loop u2 v2 q2 n2 u v k)
(let* ((uu (+ (* u v2) (* u2 v)))
(vv (+ (* v v2) (* d u u2)))
(uu (if (and (positive? m) (odd? uu)) (+ uu m) uu))
(vv (if (and (positive? m) (odd? vv)) (+ vv m) vv))
(uu (mod (/ uu 2))) (vv (mod (/ vv 2))))
(loop u2 v2 q2 n2 uu vv (* k q2)))))))))
(define (selfridge n) ; initialize lucas sequence
(let loop ((d-abs 5) (sign 1))
(let ((d (* d-abs sign)))
(cond ((< 1 (gcd d n)) (values d 0 0))
((= (jacobi d n) -1) (values d 1 (/ (- 1 d) 4)))
(else (loop (+ d-abs 2) (- sign)))))))
(define (lucas-pseudoprime? n) ; standard lucas pseudoprime
(call-with-values
(lambda () (selfridge n))
(lambda (d p q)
(if (zero? p) (= n d)
(call-with-values
(lambda () (lucas p q n (+ n 1)))
(lambda (u v qkd) (zero? u)))))))
(define (init lo) ; initialize sieve, return first prime
(set! bottom (if (< lo 3) 2 (if (odd? lo) (- lo 1) lo)))
(set! ps (cdr (primes limit))) (set! pos 0)
(set! qs (map (lambda (p) (modulo (/ (+ bottom p 1) -2) p)) ps))
(do ((p ps (cdr p)) (q qs (cdr q))) ((null? p))
(do ((i (+ (car p) (car q)) (+ i (car p)))) ((<= delta i))
(vector-set! sieve i #f)))
(if (< lo 3) 2 (next)))
(define (advance) ; advance to next segment
(set! bottom (+ bottom delta delta)) (set! pos 0)
(do ((i 0 (+ i 1))) ((= i delta)) (vector-set! sieve i #t))
(set! qs (map (lambda (p q) (modulo (- q delta) p)) ps qs))
(do ((p ps (cdr p)) (q qs (cdr q))) ((null? p))
(do ((i (car q) (+ i (car p)))) ((<= delta i))
(vector-set! sieve i #f))))
(define (next) ; next prime after current prime
(when (= pos delta) (advance))
(let ((p (+ bottom pos pos 1)))
(if (and (vector-ref sieve pos) (or (< p limit2)
(and (strong-pseudoprime? p 2) (lucas-pseudoprime? p))))
(begin (set! pos (+ pos 1)) p)
(begin (set! pos (+ pos 1)) (next)))))
(do ((pp (init low) (next)) binding ...) (test result ...) expr ...)))
((do-primes (p) (binding ...) (test result ...) expr ...)
(do-primes (p 2) (binding ...) (test result ...) expr ...))))
To get correct phasing, your next-prime needs to defined within the macro output. Here's one way to go about it (tested with Racket):
(define-syntax do-primes
(syntax-rules ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(do-primes (p lo) (binding ...) ((or test (< hi p)) res ...) exp ...))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(let ()
(define (prime? n)
...)
(define (next-prime n)
...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...)
exp ...)))
((do-primes (p) (binding ...) (test res ...) exp ...)
(do-primes (p 2) (binding ...) (test res ...) exp ...))))
This way, this defines the prime? and next-prime in the most local scope possible, while not having tons of duplicate code in your macro definition (since the 1- and 3-argument forms are simply rewritten to use the 2-argument form).
I have implemented a problem which determines the non-productive or inaccessible elements from a Grammar (Vn;Vt;P;S) where Vn - set of variables; Vt- set of terminals and P - production rules, and S - start symbol.
;;; Defining a grammar
(defvar *VN* '(A B C D S)) ; non-terminal variables
(defvar *VT* '(k m n)) ; terminal
(defvar *P* '((S A B) ; set of production rules
(S C D)
(S A k)
(A k)
(B m)
(B D m D)
(C n)))
;;; FINDING PRODUCTIVE ELEMENTS
(defun PROD-STEP (VT P PRODS)
;;(format t "P = ~S~%" P)
;;(format t "PRODS = ~S~%" PRODS)
(if (null P)
PRODS
(if (subsetp (rest (first P)) (union VT PRODS))
(PROD-STEP VT (rest P) (union (cons (first (first P)) nil) PRODS))
(PROD-STEP VT (rest P) PRODS))))
(defun PROD-AUX (VT P PRODS oldLength)
(if (= (length PRODS) oldLength)
PRODS
(PROD-AUX VT P (PROD-STEP VT P PRODS) (length PRODS))))
(defun PROD (VT P)
(PROD-AUX VT P nil -1))
;;; END OF FINDING PROD ELEMENTS
(trace PROD-STEP)
(trace PROD-AUX)
(trace PROD)
(PROD *VT* *P*)
;;; FINDING ACCESSIBLE ELEMENTS
(defun ACCESS-STEP (P ACC)
;;(format t "Pacc = ~S~%" P)
;;(format t "ACC = ~S~%" ACC)
(if (null P)
ACC
(if (member (first (first P)) ACC)
(ACCESS-STEP (rest P) (union (rest (first P)) ACC))
(ACCESS-STEP (rest P) ACC))))
(defun ACCESS-AUX (P ACC oldLength)
(if (= (length ACC) oldLength)
ACC
(ACCESS-AUX P (ACCESS-STEP P ACC) (length ACC))))
(defun ACCESS (P S)
;;(format t "Paccess = ~S~%" P)
(ACCESS-AUX P (cons S nil) 0))
;;; END OF FINDING ACCESSIBLE ELEMENTS
(trace ACCESS-STEP)
(trace ACCESS-AUX)
(trace ACCESS)
(ACCESS *P* 'S)
;;; REMOVING INACCESSIBLE AND NOT PRODUCTIVE ELEMENTS
(defun BuildRules-AUX (VT ACCS PRODS P newP)
;;(format t "newP = ~S~%" newP)
(if (null P)
newP
;; VN' = (ACCESS(G) INTERSECT PROD(G))
;; VT' = (VT INTERSECT ACCESS(G))
;; DACA REGULA ESTE A->X, A = (first (first P)) SI X = (rest (first P))
;; VERIFICAM DACA A APARTINE VN' SI X APARTINE (VT' UNION VN')
(if (and (member (first (first P)) (intersection PRODS ACCS))
(subsetp (rest (first P))
(union (intersection ACCS PRODS)
(intersection VT ACCS))))
(BuildRules-AUX VT ACCS PRODS (rest P) (union newP
(cons (first P) nil)))
(BuildRules-AUX VT ACCS PRODS (rest P) newP))))
(defun BuildRules (VT ACCS PRODS P)
(BuildRules-AUX VT ACCS PRODS P nil))
(trace BuildRules-AUX)
(trace BuildRules)
(BuildRules *VT* (ACCESS *P* 'S) (PROD *VT* *P*)*P*)
(defun SIMPL-AUX (VN VT P S ACCS PRODS)
(setq ACCS (ACCESS P S))
(setq PRODS (PROD VT P))
(if (and (null (set-difference (union VN VT) ACCS))
(null (set-difference VN PRODS)))
(cons VN (cons VT (cons P S)))
(SIMPL-AUX (intersection ACCS PRODS)
(intersection VT ACCS)
(BuildRules VT ACCS PRODS P)
S
ACCS
PRODS)))
(defun SIMPL (VN VT P S)
(SIMPL-AUX *VN* *VT* *P* 'S nil nil))
;;; END OF REMOVING INACCESSIBLE AND NOT PRODUCTIVE ELEMENTS
;;; GETTING THE RESULTS
(SIMPL *VN* *VT* *P* 'S)
But now I'm stuck with getting some intermediate results.
For productive and accessible it's clear that I would use PROD and ACCESS,
(PROD *VT* *P*)
(ACCESS *P* 'S)
but I'm not sure how to get some intermediate results for:
Non-productive
Not-accessible
as I have only one function for this:
(BuildRules *VT* (ACCESS *P* 'S) (PROD *VT* *P*) *P*)
Can you please help to figure this out?
You just need to use a replacement build-rules function that only filters for one kind of predicate. That could be written much clearer using remove-if-not, by the way.
I have implemented a problem which determines the non-productive or inaccessible elements from a Grammar (Vn;Vt;P;S) where Vn - set of variables; Vt- set of terminals and P - production rules, and S - start symbol.
; Defining a grammar
(defvar *VN* '(A B C D S)) ; non-terminal variables
(defvar *VT* '(k m n)) ; terminal
(defvar *P* '((S A B) ; set of production rules
(S C D)
(S A k)
(A k)
(B m)
(B D m D)
(C n)
)
)
;;; FINDING PRODUCTIVE ELEMENTS
(defun PROD-STEP (VT P PRODS)
;(format t "P = ~S~%" P)
;(format t "PRODS = ~S~%" PRODS)
(if (null P) PRODS
(if (subsetp (rest (first P)) (union VT PRODS))
(PROD-STEP VT (rest P) (union (cons (first (first P)) nil) PRODS))
(PROD-STEP VT (rest P) PRODS)
)
)
)
(defun PROD-AUX (VT P PRODS oldLength)
(if (= (length PRODS) oldLength)
PRODS
(PROD-AUX VT P (PROD-STEP VT P PRODS) (length PRODS))
)
)
(defun PROD (VT P)
(PROD-AUX VT P nil -1)
)
;;; END OF FINDING PROD ELEMENTS
(trace PROD-STEP)
(trace PROD-AUX)
(trace PROD)
(PROD *VT* *P*)
;;; FINDING ACCESSIBLE ELEMENTS
(defun ACCESS-STEP (P ACC)
;(format t "Pacc = ~S~%" P)
;(format t "ACC = ~S~%" ACC)
(if (null P) ACC
(if (member (first (first P)) ACC)
(ACCESS-STEP (rest P) (union (rest (first P)) ACC))
(ACCESS-STEP (rest P) ACC)
)
)
)
(defun ACCESS-AUX (P ACC oldLength)
(if (= (length ACC) oldLength)
ACC
(ACCESS-AUX P (ACCESS-STEP P ACC) (length ACC))
)
)
(defun ACCESS (P S)
;(format t "Paccess = ~S~%" P)
(ACCESS-AUX P (cons S nil) 0)
)
;;; END OF FINDING ACCESSIBLE ELEMENTS
(trace ACCESS-STEP)
(trace ACCESS-AUX)
(trace ACCESS)
(ACCESS *P* 'S)
;;; REMOVING INACCESSIBLE AND NOT PRODUCTIVE ELEMENTS
(defun BuildRules-AUX (VT ACCS PRODS P newP)
;(format t "newP = ~S~%" newP)
(if (null P) newP
; VN' = (ACCESS(G) INTERSECT PROD(G))
; VT' = (VT INTERSECT ACCESS(G))
; DACA REGULA ESTE A->X, A = (first (first P)) SI X = (rest (first P))
; VERIFICAM DACA A APARTINE VN' SI X APARTINE (VT' UNION VN')
(if (and (member (first (first P)) (intersection PRODS ACCS)) (subsetp (rest (first P)) (union (intersection ACCS PRODS) (intersection VT ACCS)) ))
(BuildRules-AUX VT ACCS PRODS (rest P) (union newP (cons (first P) nil)))
(BuildRules-AUX VT ACCS PRODS (rest P) newP)
)
)
)
(defun BuildRules (VT ACCS PRODS P)
(BuildRules-AUX VT ACCS PRODS P nil)
)
(trace BuildRules-AUX)
(trace BuildRules)
(BuildRules *VT* (ACCESS *P* 'S) (PROD *VT* *P*)*P*)
(defun SIMPL-AUX (VN VT P S ACCS PRODS)
(setq ACCS (ACCESS P S))
(setq PRODS (PROD VT P))
(if (and (null (set-difference (union VN VT) ACCS)) (null (set-difference VN PRODS)))
(cons VN (cons VT (cons P S)))
(SIMPL-AUX
(intersection ACCS PRODS)
(intersection VT ACCS)
(BuildRules VT ACCS PRODS P)
S
ACCS
PRODS
)
)
)
(defun SIMPL (VN VT P S)
(SIMPL-AUX *VN* *VT* *P* 'S nil nil)
)
;;; END OF REMOVING INACCESSIBLE AND NOT PRODUCTIVE ELEMENTS
;;; GETTING THE RESULTS
(SIMPL *VN* *VT* *P* 'S)
The program is working as expected, the only question i would like to ask how to convert the input data into strings as i would like to make difference between "a" terminal and "A" non-terminal.
I suppose i should use something like that as in input "a", "k", "*", "begin" etc..
Thank you in advance...
you can use symbols: |this is still a Symbol, which keeps its case|
|m| and M are both symbols. Different symbols.