DrBrainf-ck/gui.rkt

#lang racket/gui

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

; 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
; Returns the last state of execution of the program loaded in the editor
(define (execute-content)
  (execute
   (program->prog-state
    (string->program
     (send editor get-flattened-text)))))

; 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
  (define out (prog-state-output (execute-content)))

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

; Running output color
(define run-col (make-object color% 250 250 200))

; Output completed color
(define end-col (make-object color% 200 250 200))

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