DrBrainf-ck/gui.rkt

#lang racket/gui

(require "interpreter.rkt"
         framework
         racket/set
         racket/block)

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

; 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)
     (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)
     (send RUN-OUTPUT set-field-background end-col))))

; Definition of the run button widget
(define RUN-BTN (new button% [parent F]
                     [label "Run"]
                     ; Callback procedure for a button click:
                     [callback run-program]))

; 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

; A BFStyle is one of:
; - "Comment"
; - "Instruction"
; - "Shift"
; - "Loop"
; Interp: name of the style for a bf program token

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

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

; Syntax highlighting for brainf*ck
(send EDITOR start-colorer bf-token->bf-style bf-lexer '())

; Define basic style for instructions (+ - , .)
(define delta (make-object style-delta%))
(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")
(editor:set-standard-style-list-delta "Shift" delta)

; Define basic style for looping instructions ([ ])
(send delta set-delta-foreground "forestgreen")
(editor:set-standard-style-list-delta "Loop" delta)

; Define style of comments
(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))

; 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%
       [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 (btn ev) (input-done-cb btn ev))]))

; The run output text object
(define RUN-OUTPUT (new text-field%
                        [style (list 'multiple 'vertical-label)]
                        [label "Execution output:"]
                        [parent F]))

(define mi-open
  (new menu-item%
       [label "Open"]
       [parent m-file]
       [callback
        (lambda (i e)
          (define path (get-file #f F))
          (when path
            (send EDITOR load-file path 'text)))]
       [shortcut #\o]
       [shortcut-prefix '(ctl)]))
  
(define mi-save
  (new menu-item%
       [label "Save"]
       [parent m-file]
       [callback
        (lambda (i e)
          (send EDITOR save-file #f 'text))]
       [shortcut #\s]
       [shortcut-prefix '(ctl)]))
  
(append-editor-operation-menu-items m-edit #f)
(send EDITOR set-max-undo-history 100)
(send C set-editor EDITOR)
(send F show #t)