Psst.. new poll here.
Psst.. new forums here.
Microsoft is blocking us again (TY IP Reputation!) so just use oauth login instead. :)
Paste
Pasted as Scheme by sai ( 15 years ago )
(mac (delay exp)
`(λ () ,exp))
(def (force exp)
(exp))
(mac (seq hd tl)
`(cons ,hd (delay ,tl)))
(def (hd s)
(car s))
(def (tl s)
(force (cdr s)))
(def (range a b)
(if (< a b)
(seq a (range (+ a 1) b))
nil
))
(def (inf-range a)
(seq a (inf-range (+ a 1))))
(def (seq-filter pred s)
(if (null? s)
nil
(if (pred (hd s))
(seq (hd s) (seq-filter pred (tl s)))
(seq-filter pred (hd s)))))
(def (seq-map f s)
(if (null? s)
nil
(seq (f (hd s)) (seq-map f (tl s)))))
(mac (unless cnd . body)
`(if (not ,cnd)
(do ,@body)))
(def (force-seq s)
(unless (null? s)
(force-seq (tl s))))
(def (seq-firstn s n)
(if (= n 0)
nil
(seq (hd s) (seq-firstn (tl s) (- n 1)))))
(def (seq-first-that p s)
;(begin (prn "SEQ-FIRST-THAT: " s)
(if (null? s)
#f
(if (p (hd s))
(hd s)
(seq-first-that p (tl s)))));)
(def (seq-nth s n)
(if (= n 1)
(hd s)
(seq-nth (tl s) (- n 1))))
(def (seq->list s)
(if (null? s)
nil
(cons (hd s) (seq->list (tl s)))))
(def (make-pda . rules)
(with (pda (make-hash-table))
((afn (args)
(unless (null? args)
;(prn (car args) (cadr args))
(hash-set! pda (car args) (cadr args))
(self (cddr args)))) rules)
pda))
(def (top s)
(if (null? s)
'()
(car s)))
(def (empty? s)
(null? s))
(def (get-prod pda char sym)
(hash-ref pda (cons char sym)))
(def (next-step inp pda s)
(with (prod (get-prod pda (car inp) (top s)))
;(prn "IN NEXT-STEP: " (car prod) " " (cdr prod))
(list (cons (car prod) (cdr inp)) pda (append (cdr prod) (cdr s)))))
(def (rule-exist? pda sym char)
; (prn "IN RULE-EXIST?: " (cons char sym))
(hash-get-handle pda (cons char sym)))
(def (process-input inp pda s)
(with (char (top inp) s-top (top s))
(with (hist (cons char s-top))
(if (not (and (null? inp) (empty? s)))
(cond ((eq? s-top char)
(seq hist (process-input (cdr inp) pda (cdr s))))
((rule-exist? pda s-top char)
(seq hist (apply process-input (next-step inp pda s))))
(seq hist ((λ () nil))))
(seq hist ((λ () nil)))
))))
#!
(def (process-input inp pda s)
(with (char (top inp) s-top (top s))
(seq (cons char s-top)
(if (not (and (null? inp) (empty? s)))
(cond ( (eq? s-top char)
(process-input (cdr inp) pda (cdr s)))
( (rule-exist? pda s-top char)
(apply process-input (next-step inp pda s)))
((λ () nil)))
((λ () nil))))))
!#
(def (finite? x)
(equal? x (cons nil nil)) )
(def (comp pda inp)
(if (seq-first-that finite? (seq (cons (top inp) '(stmt)) (process-input inp pda '(stmt))))
'accept
'reject))
(def input (read))
;(prn "INPUT: " input)
;(prn "(CAR INPUT): " (car input))
(def pda (make-pda (cons 'if 'stmt) (cons 'if (list 'if '[ 'expr '] 'stmt 'else 'stmt))
(cons 'while 'stmt) (cons 'while (list 'while '[ 'expr '] 'stmt))
(cons '{ 'stmt) (cons '{ (list '{ 'stmtlist '}))
(cons 'b 'stmt) (cons 'b (list 'b))
(cons 'if 'stmtlist) (cons 'if (list 'stmt 'stmtlist))
(cons 'while 'stmtlist) (cons 'while (list 'stmt 'stmtlist))
(cons '{ 'stmtlist) (cons '{ (list 'stmt 'stmtlist))
(cons 'b 'stmtlist) (cons 'b (list 'stmt 'stmtlist))
(cons '() 'stmtlist) (cons '() (list '()))))
(prn (comp pda input))
;(force-seq (seq-map prn (seq 'not-finite (process-input input pda '(stmt)))))
Revise this Paste