Welcome, guest! Login / Register - Why register?
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

Your Name: Code Language: