Merge branch 'master' of github.com:usi-pf1-2018/pf1-project-workingffs
This commit is contained in:
commit
17cbac57eb
2 changed files with 113 additions and 40 deletions
129
gui.rkt
129
gui.rkt
|
|
@ -4,7 +4,8 @@
|
|||
(require "interpreter.rkt"
|
||||
framework
|
||||
racket/set
|
||||
racket/block)
|
||||
racket/block
|
||||
rackunit)
|
||||
|
||||
; The editor width in pixels
|
||||
(define EDITOR-WIDTH 600)
|
||||
|
|
@ -46,6 +47,9 @@
|
|||
(define init (program->prog-state
|
||||
(string->program
|
||||
(send EDITOR get-flattened-text))))
|
||||
; Put initial ProgState in step-stack
|
||||
(set! step-stack (cons init '()))
|
||||
; Execute step
|
||||
(execute-instr init after-run on-input)]
|
||||
[(cons? step-stack)
|
||||
(execute-instr (first step-stack) after-run on-input)]))
|
||||
|
|
@ -112,7 +116,6 @@
|
|||
; run the step
|
||||
(fun-to-run
|
||||
(lambda (ps)
|
||||
(print step-stack)
|
||||
(update-state-gui ps)
|
||||
(send RUN-OUTPUT set-field-background in-done-col))))
|
||||
|
||||
|
|
@ -131,6 +134,7 @@
|
|||
(new horizontal-panel%
|
||||
[parent F]
|
||||
[min-height 50]
|
||||
[alignment (list 'center 'center)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
; Definition of the run button widget
|
||||
|
|
@ -138,14 +142,18 @@
|
|||
[label "Run"]
|
||||
; Callback procedure for a button click:
|
||||
[callback run-program]))
|
||||
(define BSTEP-BTN (new button% [parent BUTTON-PANEL]
|
||||
[label "Step Back"]
|
||||
; Callback procedure for a button click:
|
||||
[callback run-step]))
|
||||
(define STEP-BACK-BTN (new button% [parent BUTTON-PANEL]
|
||||
[label "Step Back"]
|
||||
; Callback procedure for a button click:
|
||||
[callback run-step]))
|
||||
(define STEP-BTN (new button% [parent BUTTON-PANEL]
|
||||
[label "Step Fwd"]
|
||||
; Callback procedure for a button click:
|
||||
[callback run-step]))
|
||||
[label "Step Fwd"]
|
||||
; Callback procedure for a button click:
|
||||
[callback run-step]))
|
||||
(define STEP-STOP-BTN (new button% [parent BUTTON-PANEL]
|
||||
[label "Stop Step"]
|
||||
; Callback procedure for a button click:
|
||||
[callback (lambda (_ __) (set! step-stack '()))]))
|
||||
|
||||
; Definition of the editor canves
|
||||
(define C (new editor-canvas% [parent F]))
|
||||
|
|
@ -168,6 +176,13 @@
|
|||
; - 'loop
|
||||
; Interp: category of a bf program token
|
||||
|
||||
; Template for BFToken
|
||||
#; (define (fn-for-bf-token t)
|
||||
#; (cond [(symbol=? t 'comment) ...]
|
||||
#; [(symbol=? t 'instruction) ...]
|
||||
#; [(symbol=? t 'shift) ...]
|
||||
#; [(symbol=? t 'loop) ...]))
|
||||
|
||||
; A BFStyle is one of:
|
||||
; - "Comment"
|
||||
; - "Instruction"
|
||||
|
|
@ -175,6 +190,13 @@
|
|||
; - "Loop"
|
||||
; Interp: name of the style for a bf program token
|
||||
|
||||
; Template for BFToken
|
||||
#; (define (fn-for-bf-style t)
|
||||
#; (cond [(string=? t "Comment") ...]
|
||||
#; [(string=? t "Instruction") ...]
|
||||
#; [(string=? t "Shift") ...]
|
||||
#; [(string=? t "Loop") ...]))
|
||||
|
||||
; bf-token->bf-style: BFToken -> BFStyle
|
||||
; Given a BFToken, returns the corresponding BFStyle.
|
||||
(define (bf-token->bf-style token)
|
||||
|
|
@ -183,6 +205,12 @@
|
|||
[(symbol=? token 'shift) "Shift"]
|
||||
[(symbol=? token 'instruction) "Instruction"]))
|
||||
|
||||
; Tests for bf-token->bf-style
|
||||
(check-equal? (bf-token->bf-style 'comment) "Comment")
|
||||
(check-equal? (bf-token->bf-style 'loop) "Loop")
|
||||
(check-equal? (bf-token->bf-style 'shift) "Shift")
|
||||
(check-equal? (bf-token->bf-style 'instruction) "Instruction")
|
||||
|
||||
; bf-lexer: InputPort -> (values 1String BFToken #f Option<Nat> Option<Nat>)
|
||||
; Given an input port, returns the BFToken of the instruction pointed by the
|
||||
; port.
|
||||
|
|
@ -197,26 +225,64 @@
|
|||
[(set-member? (set "<" ">") 1str) 'shift]
|
||||
[(set-member? (set "[" "]") 1str) 'loop]
|
||||
[else 'comment]))
|
||||
(values 1str bf-token #f (+ pos) (+ pos 1))]))
|
||||
(values 1str bf-token #f pos (+ pos 1))]))
|
||||
|
||||
; Syntax highlighting for brainf*ck
|
||||
; Tests from bf-lexer
|
||||
(begin
|
||||
(let ([program-port (open-input-string "+--+++Comment[]")])
|
||||
(define-values (a b c d e) (bf-lexer program-port))
|
||||
(check-equal? a "+")
|
||||
(check-equal? b 'instruction)
|
||||
(check-equal? c #f)
|
||||
(check-equal? d 1)
|
||||
(check-equal? e 2)))
|
||||
(begin
|
||||
(let ([program-port (open-input-string "--")])
|
||||
(define-values (a b c d e) (bf-lexer program-port))
|
||||
(check-equal? a "-")
|
||||
(check-equal? b 'instruction)
|
||||
(check-equal? c #f)
|
||||
(check-equal? d 1)
|
||||
(check-equal? e 2)))
|
||||
(begin
|
||||
(let ([program-port (open-input-string "Comments!")])
|
||||
(define-values (a b c d e) (bf-lexer program-port))
|
||||
(check-equal? a "C")
|
||||
(check-equal? b 'comment)
|
||||
(check-equal? c #f)
|
||||
(check-equal? d 1)
|
||||
(check-equal? e 2)))
|
||||
(begin
|
||||
(let ([program-port (open-input-string "Car<>")])
|
||||
; Use the input port three times to use bf-lexer on the "<" char
|
||||
(let-values ([(_ __ ___) (port-next-location program-port)]) (void))
|
||||
(let-values ([(_ __ ___) (port-next-location program-port)]) (void))
|
||||
(let-values ([(_ __ ___) (port-next-location program-port)]) (void))
|
||||
(define-values (a b c d e) (bf-lexer program-port))
|
||||
(check-equal? a "C")
|
||||
(check-equal? b 'comment)
|
||||
(check-equal? c #f)
|
||||
(check-equal? d 1)
|
||||
(check-equal? e 2)))
|
||||
|
||||
; Enable syntax highlighting for brainf*ck (with lexer)
|
||||
(send EDITOR start-colorer bf-token->bf-style bf-lexer '())
|
||||
|
||||
; Define basic style for instructions (+ - , .)
|
||||
; Define style for instructions (+ - , .)
|
||||
(define delta (make-object style-delta%))
|
||||
(send delta set-delta-foreground "blue")
|
||||
(void (send delta set-delta-foreground "blue"))
|
||||
(editor:set-standard-style-list-delta "Instruction" delta)
|
||||
|
||||
; Define style for shifting operations (< >)
|
||||
(send delta set-delta-foreground "red")
|
||||
(void (send delta set-delta-foreground "red"))
|
||||
(editor:set-standard-style-list-delta "Shift" delta)
|
||||
|
||||
; Define basic style for looping instructions ([ ])
|
||||
(send delta set-delta-foreground "forestgreen")
|
||||
; Define style for looping instructions ([ ])
|
||||
(void (send delta set-delta-foreground "forestgreen"))
|
||||
(editor:set-standard-style-list-delta "Loop" delta)
|
||||
|
||||
; Define style of comments
|
||||
(send delta set-delta-foreground "orange")
|
||||
(void (send delta set-delta-foreground "orange"))
|
||||
(editor:set-standard-style-list-delta "Comment" delta)
|
||||
|
||||
; Input done color
|
||||
|
|
@ -228,11 +294,6 @@
|
|||
; Output completed color
|
||||
(define end-col (make-object color% 200 250 200))
|
||||
|
||||
; Populate menu bar
|
||||
(define MB (new menu-bar% [parent F]))
|
||||
(define m-file (new menu% [label "File"] [parent MB]))
|
||||
(define m-edit (new menu% [label "Edit"] [parent MB]))
|
||||
|
||||
; The tape panel
|
||||
(define tape-panel
|
||||
(new horizontal-panel%
|
||||
|
|
@ -296,10 +357,18 @@
|
|||
[label "Execution output:"]
|
||||
[parent F]))
|
||||
|
||||
(define mi-open
|
||||
; Populate menu bar
|
||||
(define MB (new menu-bar% [parent F]))
|
||||
|
||||
; Create "File" and "Edit" menu "lists"
|
||||
(define FILE-MENU (new menu% [label "File"] [parent MB]))
|
||||
(define EDIT-MENU (new menu% [label "Edit"] [parent MB]))
|
||||
|
||||
; Menu element for opening a new file
|
||||
(define MENU-OPEN
|
||||
(new menu-item%
|
||||
[label "Open"]
|
||||
[parent m-file]
|
||||
[parent FILE-MENU]
|
||||
[callback
|
||||
(lambda (i e)
|
||||
(define path (get-file #f F))
|
||||
|
|
@ -308,17 +377,23 @@
|
|||
[shortcut #\o]
|
||||
[shortcut-prefix '(ctl)]))
|
||||
|
||||
(define mi-save
|
||||
; Menu element for saving the current file
|
||||
(define MENU-SAVE
|
||||
(new menu-item%
|
||||
[label "Save"]
|
||||
[parent m-file]
|
||||
[parent FILE-MENU]
|
||||
[callback
|
||||
(lambda (i e)
|
||||
(send EDITOR save-file #f 'text))]
|
||||
[shortcut #\s]
|
||||
[shortcut-prefix '(ctl)]))
|
||||
|
||||
(append-editor-operation-menu-items m-edit #f)
|
||||
; Add default menu elements to "edit" menu
|
||||
(append-editor-operation-menu-items EDIT-MENU #f)
|
||||
|
||||
; Set max undo history for editor
|
||||
(send EDITOR set-max-undo-history 100)
|
||||
|
||||
; Init editor
|
||||
(send C set-editor EDITOR)
|
||||
(send F show #t)
|
||||
|
|
|
|||
|
|
@ -408,18 +408,16 @@
|
|||
; computed by executing the program
|
||||
(define (execute prog done get-input)
|
||||
|
||||
; The program length in characters
|
||||
(define program-len (string-length (prog-state-program prog)))
|
||||
|
||||
; execute-help: ProgState -> _
|
||||
; execute-help: ProgState ProgState -> _
|
||||
; Helper function for `execute`.
|
||||
; Given an initial ProgState state, calls done
|
||||
; when the final ProgState is ready.
|
||||
(define (execute-help w)
|
||||
(cond [(>= (prog-state-ip w) program-len) (done w)]
|
||||
[else (execute-instr w execute-help get-input)]))
|
||||
; Given an initial ProgState state, and the previous state,
|
||||
; calls done when the final ProgState is ready.
|
||||
(define (execute-help w prev)
|
||||
(cond [(eq? w #f) (done prev)]
|
||||
[else (execute-instr w (lambda (new) (execute-help new w))
|
||||
get-input)]))
|
||||
|
||||
(execute-help prog))
|
||||
(execute-instr prog (lambda (new) (execute-help new prog)) get-input))
|
||||
|
||||
; Tests for execute
|
||||
(test-begin
|
||||
|
|
|
|||
Loading…
Reference in a new issue