DrBrainf-ck/gui.rkt

#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 end-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))
  ; update data tape inspector
  (make-tape-cells ps)
  ; set output and change color to ended
  (send RUN-OUTPUT set-value out))

; 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))

; 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)