Added more tests/comments and fixed bug in stepper regarding initial state
This commit is contained in:
Claudio Maggioni
parent
c19a9da695
commit
8a1af32dcb
135
gui.rkt
135
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%
|
||||
|
|
@ -257,7 +318,7 @@
|
|||
(send c set-canvas-background (if hl end-col run-col))
|
||||
(send dc draw-text (send c get-label) 12.5 10)
|
||||
(send dc draw-text content 12.5 30))]))
|
||||
|
||||
|
||||
; make-tape-cells: ProgState -> _
|
||||
; Given a ProgState, empties the data tape inspector and creates the
|
||||
; corresponding cells as canvasas in the tape inspector.
|
||||
|
|
@ -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))
|
||||
|
|
@ -307,18 +376,24 @@
|
|||
(send EDITOR load-file path 'text)))]
|
||||
[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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue