PasteRack.org
Paste # 61516
2018-04-08 23:23:57

Fork as a new paste.

Paste viewed 367 times.


Embed:

#lang racket/gui

(define bbgui ; main dialog for creation parameters
  (class object%
    (super-new)  
    
    (define iTextVals ; text field defaults
      '([GalaxyName   "Milky Way"]
        [OriginSystem "Sol"]
        [HomeWorld    "Earth"]
        [Creator      ""]))

    (define iSliderVals ; slider defaults
      '([GalaxySize   30  10  100]
        [SpiralArms   2   1   7]
        [Systems      700 100 1000]
        [Planets      7   3   13]
        [Chaos        17  3   42]
        [Variance     43  0   100]))

    (define (slNew Parent key) ; slider generator
      (new slider% [parent Parent]
           [label (symbol->string key)]
           [style '(vertical vertical-label)] [min-width 60]
           [init-value (car (dict-ref iSliderVals key))]
           [min-value (cadr (dict-ref iSliderVals key))]
           [max-value (caddr (dict-ref iSliderVals key))]
           [callback (λ (slider event)
                       (send bbStatus set-label (~a (symbol->string key) " updated")))]))

    (define (txNew Parent key) ; Text field generator
      (new text-field% [parent Parent]
           [label (symbol->string key)]
           [style '(single vertical-label)] [min-width 100]
           [init-value (car (dict-ref iTextVals key))]
           [callback (λ (text-field event)
                       (send bbStatus set-label (~a (symbol->string key) " updated")))]))
    
    (define/public (reset) ; reset everything to initial values
      (define ctrlset (append txts sliders))
      (define ivset (append iTextVals iSliderVals))
      (map (λ (control)
             (send control set-value
                   (car (dict-ref ivset (string->symbol (send control get-label))))))
           ctrlset)
      (send bbfrm refresh)) ; refresh needed to repaint text fields
    
    ; Stub output function
    (define/public (read)
      (map (λ (control)
             (cons (string->symbol (send control get-label)) (send control get-value)))
           (append txts sliders)))
    
    ; Begin Creating Objects
    (define bbfrm (new frame% [label "Big Bang"])) ; create the main frame
    (define bbTopStatus ; Make a top status field
      (new message% [parent bbfrm] [label ""]))
    (define mpanel (new horizontal-pane% [parent bbfrm])) ; main pane
    (define slpanel (new horizontal-pane% [parent mpanel])) ; slider pane
    (define txpanel (new vertical-pane% [parent mpanel])) ; text field pane
    (define bbar (new horizontal-pane% [parent bbfrm])) ; button bar pane

    (define sliders '()) ; generate the slider set
    (map (λ (key) (set! sliders (append sliders (list (slNew slpanel key)))))
         (map (λ (k) (car k)) iSliderVals))

    (define txts '()) ; set up the text boxes
    (map (λ (key) (set! txts (append txts (list (txNew txpanel key)))))
         (map (λ (k) (car k)) iTextVals))
   
    (new button% [parent bbar] [label "Run"] ; Add a Run button
         [callback (λ (button event)
                     (send bbStatus set-label "Run was pressed")
                     (displayln (read)))]) ; right now just output to console
    
    (new button% [parent bbar] [label "Reset"] ; Add a Reset button
         [callback (λ (button event)
                     (reset) ; call the function defined above
                     (send bbStatus set-label "Reset was pressed"))])
    
    ; Make a status bar text message
    (define bbStatus (new message% [parent bbfrm] [label "Defaults Loaded"]))
      
    (send bbfrm show #t))) ; finish up and display the window.
; end of bbgui definition

; create an instance on startup
(define bb (new bbgui))