Paste: Some code

! Copyright (C) 2009 Søren Enevoldsen.
! See http://factorcode.org/license.txt for BSD license.
! Simulates the IEEE 754 (32 bit) floating point number.

USING: kernel namespaces sequences arrays math math.ranges 
       math.parser combinators ui.pens.solid accessors
       colors ui ui.render ui.gadgets ui.gadgets.buttons 
       ui.gadgets.labels ui.gadgets.packs io.styles fonts ;

QUALIFIED: models

IN: 754

! TODO: Fix somewhat ugly code!
! TODO: Make UI resize better (waiting for unresizable windows).
! TODO: Get rid of warnings (Gone in latest build).

! Related to the label that contains the value of the float.
: create-float ( -- ) 32 0 <array> "array" set-global ;
: get-array ( -- seq ) "array" get-global ;
: array-num ( -- m ) get-array [ number>string ] map concat bin> bits>float ;
: update-label ( -- ) array-num number>string "model" get-global models:set-model ;

! Label related
: label-get ( button -- label ) children>> first ;
: label-bit-get ( label -- m ) text>> string>number ;
: label-bit-set ( label m -- ) number>string >>text drop ;

! Button related
: button-bit-get ( button -- m ) label-get label-bit-get ;
: visual-update ( button -- ) label-get dup label-bit-get 0 = [ 1 ] [ 0 ] if label-bit-set ;
: button-click ( button n -- ) over visual-update
                              [ button-bit-get ] dip get-array [ set-nth ] keep
                              "array" set-global update-label ;

                             
: set-button-size ( button -- button ) { 10 10 } >>size ;

! Brushes
: <red-brush> ( -- rgba ) 1.0 0.7 0.7 1.0 <rgba> <solid> ;
: <green-brush> ( -- rgba ) 0.7 1.0 0.7 1.0 <rgba> <solid> ;
: <blue-brush> ( -- rgba ) 0.7 0.7 1.0 1.0 <rgba> <solid> ;


! Create buttons for gui
: choose-color ( n -- brush ) { { [ dup 1 < ] [ drop <blue-brush> ] } 
                                { [ dup 9 < ] [ drop <green-brush> ] } 
                                { [ drop t ] [ <red-brush> ] } } cond ;

! Center label
: <center> ( child -- parent ) <pile> 1/2 >>align swap add-gadget ;
                                
: set-button-color ( n button -- button ) swap choose-color >>interior ;
: set-button-font ( button -- button ) dup label-get <font> "sans-serif" >>name 16 >>size >>font drop ;

: create-button-32 ( parent n -- parent ) "0" over [ button-click ] curry <roll-button>
        set-button-size set-button-color set-button-font add-gadget ;
    
: create-buttons-32 ( parent -- parent ) 0 31 [a,b] [ create-button-32 ] each ;

: create-font ( n -- font ) <font> swap >>size t >>bold? "sans-serif" >>name ;

: ui-show ( -- )
    [ 
            <pile> 1 >>fill
            "Simulation of the IEEE 754 floating point number" <label>
                22 create-font >>font <center> add-gadget
                
                    <shelf>
                    create-buttons-32
                    <center>
                    add-gadget
            0.0 models:<model> dup [ number>string ] models:change-model dup "model" set-global 
                <label-control> 18 create-font >>font <center> add-gadget
                
            "My test program" open-window
    ] with-ui ;

: program ( -- ) create-float ui-show ;

MAIN: program