404 lines
13 KiB
Racket
404 lines
13 KiB
Racket
#lang racket/gui
|
|
; vim: set tw=80 :
|
|
|
|
(require "interpreter.rkt"
|
|
framework
|
|
racket/set
|
|
racket/block
|
|
rackunit)
|
|
|
|
; The editor width in pixels
|
|
(define EDITOR-WIDTH 600)
|
|
(define EDITOR-HEIGHT 600)
|
|
|
|
; The frame racket/gui base object for the editor
|
|
(define F (new frame%
|
|
[label "DrBrainf*ck"]
|
|
[width EDITOR-WIDTH]
|
|
[height EDITOR-HEIGHT]))
|
|
|
|
; execute-content: (ProgState -> _) -> _
|
|
; Given a callback, calls the callback with the last state of execution of the
|
|
; program loaded in the editor
|
|
(define (execute-content done)
|
|
(execute
|
|
(program->prog-state
|
|
(string->program
|
|
(send EDITOR get-flattened-text)))
|
|
done on-input))
|
|
|
|
; Stack of execution for stepper (List<ProgState>)
|
|
(define step-stack '())
|
|
|
|
; execute-step: (ProgState -> _) -> _
|
|
; Given a callback, if step-stack is empty, updates step-stack as a list with
|
|
; only the first step of execution; otherwise, it computes the next step of
|
|
; execution, it puts it on top of step-stack, and calls the callback with that.
|
|
(define (execute-step done)
|
|
|
|
; after-run: Option<ProgState> -> _
|
|
; Given a ProgState, it puts it in the t.o.s. of step-stack and executes done.
|
|
(define (after-run ps)
|
|
(cond [(eq? ps #f) (void)]
|
|
[else (set! step-stack (cons ps step-stack))
|
|
(done ps)]))
|
|
|
|
(cond [(empty? step-stack)
|
|
(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)]))
|
|
|
|
; execute-step-back: (ProgState -> _) -> _
|
|
; Given a callback, if step-stack is empty or of length 1, does nothing;
|
|
; otherwise, it fetches the previous step of execution, it puts it on top of
|
|
; step-stack (by popping and discarding the t.o.s.) and calls the callback with
|
|
; that.
|
|
(define (execute-step-back done)
|
|
(cond [(empty? step-stack) (void)]
|
|
[(empty? (rest step-stack)) (void)]
|
|
[(cons? step-stack)
|
|
(set! step-stack (rest step-stack))
|
|
(done (first step-stack))]))
|
|
|
|
; on-input: (Byte -> _) -> _
|
|
; Given a a callback to resume execution, sets up the run input area (callback
|
|
; included).
|
|
(define (on-input callback)
|
|
(send RUN-INPUT set-field-background run-col)
|
|
(if (non-empty-string? (send RUN-INPUT get-value))
|
|
(on-input-done callback)
|
|
(set! input-done-cb (lambda (_ __) (on-input-done callback)))))
|
|
|
|
; on-input-done: (Byte -> _) -> _
|
|
; Given a callback to resume execution, fetches the first character from
|
|
; `RUN-INPUT` "consuming" it and resumes execution.
|
|
(define (on-input-done callback)
|
|
(define old-str (send RUN-INPUT get-value))
|
|
; Continue only if there is input
|
|
(if (non-empty-string? old-str)
|
|
(block
|
|
; Disable input callback
|
|
(set! input-done-cb (lambda (_ __) (void)))
|
|
; Pick first char from run input "consuming" it
|
|
(define in (string-ref old-str 0))
|
|
(define new-str (substring old-str 1))
|
|
(send RUN-INPUT set-value new-str)
|
|
; Remove waiting color from run-input
|
|
(send RUN-INPUT set-field-background in-done-col)
|
|
; Resume execution
|
|
(callback (char->integer in)))
|
|
(void)))
|
|
|
|
; run-program: Button ControlEvent -> Nothing
|
|
; Given a button and an event, runs the program currently loaded in the editor.
|
|
(define (run-program button event)
|
|
; empty output text and set color to running
|
|
(send RUN-OUTPUT set-value "")
|
|
(send RUN-OUTPUT set-field-background run-col)
|
|
; run the program
|
|
(execute-content
|
|
(lambda (ps)
|
|
(update-state-gui ps)
|
|
(send RUN-OUTPUT set-field-background
|
|
(if (eq? (prog-state-error ps) #f) end-col err-col)))))
|
|
|
|
; run-step: Button ControlEvent -> Nothing
|
|
; Given the step button pressed and an event, runs the matching step (step or
|
|
; step-back) updating the GUI.
|
|
(define (run-step b event)
|
|
; Determine matching function to run (based on the type of step)
|
|
(define fun-to-run (if (eqv? b STEP-BTN) execute-step execute-step-back))
|
|
; run the step
|
|
(fun-to-run
|
|
(lambda (ps)
|
|
(update-state-gui ps)
|
|
(send RUN-OUTPUT set-field-background in-done-col))))
|
|
|
|
; update-state-gui: ProgState -> _
|
|
; Given a prog-state, updates the data tape inspector and the output window with
|
|
; the contents of that prog-state.
|
|
(define (update-state-gui ps)
|
|
(define out (prog-state-output ps))
|
|
(define err (prog-state-error ps))
|
|
; update data tape inspector
|
|
(make-tape-cells ps)
|
|
; set output
|
|
(send RUN-OUTPUT set-value (string-append out "\n" (if (eq? err #f) "" err))))
|
|
|
|
; The tape panel
|
|
(define BUTTON-PANEL
|
|
(new horizontal-panel%
|
|
[parent F]
|
|
[min-height 50]
|
|
[alignment (list 'center 'center)]
|
|
[stretchable-height #f]))
|
|
|
|
; Definition of the run button widget
|
|
(define RUN-BTN (new button% [parent BUTTON-PANEL]
|
|
[label "Run"]
|
|
; Callback procedure for a button click:
|
|
[callback run-program]))
|
|
(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]))
|
|
(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]))
|
|
|
|
; Definition of editor text object.
|
|
(define text-pro% (text:line-numbers-mixin
|
|
(editor:standard-style-list-mixin
|
|
(color:text-mixin
|
|
(text:basic-mixin
|
|
(editor:basic-mixin text%))))))
|
|
(define EDITOR (new text-pro%))
|
|
|
|
; Show line numbers in editor
|
|
(send EDITOR show-line-numbers! #t)
|
|
|
|
; A BFToken is one of:
|
|
; - 'comment
|
|
; - 'instruction
|
|
; - 'shift
|
|
; - '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"
|
|
; - "Shift"
|
|
; - "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)
|
|
(cond [(symbol=? token 'comment) "Comment"]
|
|
[(symbol=? token 'loop) "Loop"]
|
|
[(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.
|
|
(define (bf-lexer port)
|
|
(define-values (_ __ pos) (port-next-location port))
|
|
(define c (read-char port))
|
|
(cond [(eof-object? c) (values c 'eof #f #f #f)]
|
|
[else
|
|
(define 1str (string c))
|
|
(define bf-token
|
|
(cond [(set-member? (set "+" "-" "," ".") 1str) 'instruction]
|
|
[(set-member? (set "<" ">") 1str) 'shift]
|
|
[(set-member? (set "[" "]") 1str) 'loop]
|
|
[else 'comment]))
|
|
(values 1str bf-token #f pos (+ pos 1))]))
|
|
|
|
; 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 style for instructions (+ - , .)
|
|
(define delta (make-object style-delta%))
|
|
(void (send delta set-delta-foreground "blue"))
|
|
(editor:set-standard-style-list-delta "Instruction" delta)
|
|
|
|
; Define style for shifting operations (< >)
|
|
(void (send delta set-delta-foreground "red"))
|
|
(editor:set-standard-style-list-delta "Shift" delta)
|
|
|
|
; Define style for looping instructions ([ ])
|
|
(void (send delta set-delta-foreground "forestgreen"))
|
|
(editor:set-standard-style-list-delta "Loop" delta)
|
|
|
|
; Define style of comments
|
|
(void (send delta set-delta-foreground "orange"))
|
|
(editor:set-standard-style-list-delta "Comment" delta)
|
|
|
|
; Input done color
|
|
(define in-done-col (make-object color% 255 255 255))
|
|
|
|
; Running output color
|
|
(define run-col (make-object color% 250 250 200))
|
|
|
|
; Output completed color
|
|
(define end-col (make-object color% 200 250 200))
|
|
|
|
; Error color
|
|
(define err-col (make-object color% 250 200 200))
|
|
|
|
; The tape panel
|
|
(define tape-panel
|
|
(new horizontal-panel%
|
|
[parent F]
|
|
[min-height 50]
|
|
[style (list 'auto-hscroll)]
|
|
[stretchable-height #f]))
|
|
|
|
; make-cell: Nat Byte Boolean -> Canvas
|
|
; Given a cell index, the cell contents, and a boolean set to #t when the cell
|
|
; is pointed by the data pointer, returns the rendered cell as a Canvas.
|
|
(define (make-cell index content hl)
|
|
(new canvas%
|
|
[parent tape-panel]
|
|
[min-height 50]
|
|
[min-width 50]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[label (string-append (number->string index) ":")]
|
|
[paint-callback
|
|
(lambda (c dc)
|
|
(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.
|
|
(define (make-tape-cells ps)
|
|
(define dt (prog-state-tape ps))
|
|
(send tape-panel change-children (lambda (_) '()))
|
|
(for ([i (in-range 0 (prog-state-tape-len ps))]
|
|
[tp dt])
|
|
(make-cell i (number->string tp) (= i (prog-state-dp ps)))))
|
|
|
|
; The input horizontal panel
|
|
(define input-panel
|
|
(new horizontal-panel%
|
|
[parent F]
|
|
[min-height 50]
|
|
[stretchable-height #f]))
|
|
|
|
; Input needed in program execution
|
|
(define RUN-INPUT (new text-field%
|
|
[label "Execution input:"]
|
|
[parent input-panel]))
|
|
|
|
; The input done callback (defaults to nothing)
|
|
; Type: (Button Event) -> _
|
|
(define input-done-cb (lambda (btn ev) (void)))
|
|
|
|
; Definition of the run button widget
|
|
(define INPUT-DONE-BTN (new button%
|
|
[parent input-panel]
|
|
[label "Confirm"]
|
|
[callback (lambda (b ev) (input-done-cb b ev))]))
|
|
|
|
; The run output text object
|
|
(define RUN-OUTPUT (new text-field%
|
|
[style (list 'multiple 'vertical-label)]
|
|
[label "Execution output:"]
|
|
[parent F]))
|
|
|
|
; 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 FILE-MENU]
|
|
[callback
|
|
(lambda (i e)
|
|
(define path (get-file #f F))
|
|
(when path
|
|
(send EDITOR load-file path 'text)))]
|
|
[shortcut #\o]
|
|
[shortcut-prefix '(ctl)]))
|
|
|
|
; Menu element for saving the current file
|
|
(define MENU-SAVE
|
|
(new menu-item%
|
|
[label "Save"]
|
|
[parent FILE-MENU]
|
|
[callback
|
|
(lambda (i e)
|
|
(send EDITOR save-file #f 'text))]
|
|
[shortcut #\s]
|
|
[shortcut-prefix '(ctl)]))
|
|
|
|
; 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)
|