b e b b
b b b

f b e b b
f b b b

b bqb
.b -text moo -bg red
.b2 -text cow
.bq -bg green

#! /bin/sh
# \
exec tclsh "$0" ${1+"$@"}

namespace eval gub {

package provide gub 0.2



#
#
#
proc gub {gob {var {gui}}} {
        set rg {}

        foreach a {N C R S P G V H} { array set $a {} }

        array set W [list \
                b button \
                c canvas \
                k checkbutton \
                e entry \
                f frame \
                l label \
                z labelframe \
                o listbox \
                r radiobutton \
                y scale \
                s scrollbar \
                i spinbox \
                t text \
                B ttk::button \
                K ttk::checkbutton \
                X ttk::combobox \
                E ttk::entry \
                F ttk::frame \
                L ttk::label \
                Z ttk::labelframe \
                N ttk::notebook \
                R ttk::radiobutton \
                Y ttk::scale \
                S ttk::scrollbar \
                V ttk::treeview \
        ]

        foreach w [array names W] { set N([string tolower $w]) -1 }

        array set wigs {. $W}

        set toprocess {}
        foreach l [split $gob \n] {
                set l [string trimright $l]
                set ll [string trimleft $l]
                if {$ll eq "" || [string index $ll 0] eq "#"} { continue }
                foreach l [split $l \;] {
                        set l [string trimright $l]
                        set ll [string trimleft $l]
                        if {[set c [string index $ll 0]] ni {. / : = ^ | -}} {
                                lappend toprocess $l
                        } else {
                                if {[set i [string first " " $ll]] != -1} {
                                        set n [string range $ll 1 $i-1]
                                        set v [string range $ll $i+1 end]
                                } else {
                                        set n [string range $ll 1 end]
                                        set v ""
                                }
                                set vv [string trimright $v]
                                foreach n [split $n +] {
                                        set v $vv
                                        switch -exact -- $c {
                                        . { lappend P($n) {*}$v }
                                        / { set S($n) $v }
                                        : { if {$v eq ""} {set v "-sticky nsew"}; set G($n) $v }
                                        = { set H($n) $v }
                                        ^ { set V($n) $v }
                                        | { if {$v eq ""} {set v "0 -weight 1"}; lappend C($n) $v }
                                        - { if {$v eq ""} {set v "0 -weight 1"}; lappend R($n) $v }
                                        default {}
                                        }
                                }
                        }
                }
        }

        set row 0
        set col 0
        set fr {}
        foreach l $toprocess {
                set zl {grid}
                if {[string length $l] % 2 != 0} { append l " " }
                set start 1
                foreach {c m} [split $l ""] {
                        if {$c eq " " && $m eq " "} {
                                set start 0;continue
                        } elseif {$start} {
                                set fr {}
                        }
                        set start 0

                        set d {[}
                        lappend d $W($c)
                        lappend d { }

                        set wig \$w.$fr[set lc [string tolower $c]][set n [incr N($lc)]]
                        lappend d $wig
                        set wigs($c$n) $wig
                        if {$m ne "" && $m ne " "} { set wigs($c$m) $wig }

                        array unset p
                        array set p {}
                        if {[info exists P($c)]} { array set p $P($c) }
                        if {[info exists P($c$n)]} { array set p $P($c$n) }
                        if {$m ne "" && $m ne " " && [info exists P($c$m)]} {
                                array set p $P($c$m)
                        }
                        if {[llength [array names p]] > 0} {
                                lappend d { }
                                lappend d [array get p]
                        }
                        lappend d {]}

                        if {[info exists S($c$m)]} {
                                set d [linsert $d 0 "\[set ${var}($S($c$m)) "]
                                lappend d {]}
                        } elseif {[info exists S($c$n)]} {
                                set d [linsert $d 0 "\[set ${var}($S($c$n)) "]
                                lappend d {]}
                        }

                        array unset g
                        array set g {}
                        if {[info exists G($c)]} { array set g $G($c) }
                        if {[info exists G($c$n)]} { array set g $G($c$n) }
                        if {$m ne "" && $m ne " " && [info exists G($c$m)]} {
                                array set g $G($c$m)
                        }
                        if {[llength [array names g]] > 0} {
                                lappend d { }
                                lappend d [array get g]
                        }

                        if {[llength $d] > 0} {
                                lappend zl [join $d ""]
                                set d {}
                        }

                        if {$c in "f F"} {
                                set fr [string tolower $c]$n.
                                lappend rg [join $zl]
                                set zl grid
                        }
                }
                if {[llength $zl] > 1} {
                        lappend rg [join $zl]
                }
        }

        if {[llength [array names C]] > 0 || [llength [array names R]] > 0} { lappend rg {} }
        foreach {n v} [array get C] { foreach o $v {
                lappend rg "grid columnconfigure $wigs($n) $o"
        }}
        foreach {n v} [array get R] { foreach o $v {
                lappend rg "grid rowconfigure $wigs($n) $o"
        }}

        if {[llength [array names H]] > 0 || [llength [array names V]] > 0} { lappend rg {} }
        foreach {n v} [array get H] {
                lappend rg "$wigs($n) configure -command \[list $wigs($v) xview\]"
                lappend rg "$wigs($v) configure -xscroll \[list $wigs($n) set\]"
        }
        foreach {n v} [array get V] {
                lappend rg "$wigs($n) configure -command \[list $wigs($v) yview\]"
                lappend rg "$wigs($v) configure -yscroll \[list $wigs($n) set\]"
        }

        return [regsub -line -all {^\t$} [join $rg \n\t] {}]
}
###



#
#
#
proc gubProc {blob {name {widget}} {var {gui}}} {
        return [regsub -line -all {^\t$} [join [list "proc $name {{w {.}}} \{" {set W $w; if {$w eq "."} {set w ""}} "variable $var" "" $blob "" {return $W}] \n\t]\n\} {}]
}
###


}; # End of gub namespace

# EOF

#! /bin/sh
# \
exec tclsh "$0" ${1+"$@"}

#
# TkGub - GUI frontend to Gub
#
# Stuart Cassoff
# Fall/Winter 2008
#
# Version 0.2
#


namespace eval tkgub {

package require Tk
package require Ttk
package require gub


#
#
#
proc gui {} {
        variable gui

        set w [set gui(w) {}]
        set W [set gui(W) $w.]

        eval [gub::gub "
# TkGub gui

fitisv
  sh
fotosv
  sh

.t -height 10 -wrap none
.sh -orient horizontal

^s0 t0 ; =s1 t0
^s2 t1 ; =s3 t1

:sv
:sh -sticky ew
:f

|fi+fo+.
-fi+fo+.
-. 1 -weight 1
 
/ti in
/to out

"]

        set M [menu $w.mMain -tearoff 0]
        set menu file
        set mm [menu $M.$menu -tearoff 0]
        $mm add command -label Load -command [namespace current]::Load
        $mm add command -label Save -command [namespace current]::Save
        $mm add command -label Exit -command exit
        $M add cascade -label [string totitle $menu] -menu $mm
        set menu help
        set mm [menu $M.$menu -tearoff 0]
        $mm add command -label About -command [namespace current]::about
        $mm add command -label Readme -command [namespace current]::readme
        $M add cascade -label [string totitle $menu] -menu $mm

        foreach t {in out} { bind $gui($t) <Control-Return> [namespace current]::run\;break }

        bind a <Key> [namespace current]::gubrun
        bind a <Control-Return> [namespace current]::gubrun\;break
        bind b <Control-Return> [namespace current]::run\;break
        bindtags $gui(in)  [linsert [bindtags $gui(in)] end a]
        bindtags $gui(out) [linsert [bindtags $gui(in)] end b]

        bind $W <Control-q> exit; bind $W <Control-Q> exit

        bind $W <Button-3> [list [namespace current]::domenu %W [mwowm $w] %X %Y]

        $W configure -menu $M

        wm title $W TkGub\ 0.2

        focus $gui(in)
}
###



#
#
#
proc mwowm {w} {
        set widgets [list button canvas checkbutton entry frame label labelframe listbox radiobutton scale scrollbar spinbox text]
        lappend widgets {*}[list \
                ttk::button \
                ttk::checkbutton \
                ttk::combobox \
                ttk::entry \
                ttk::frame \
                ttk::label \
                ttk::labelframe \
                ttk::notebook \
                ttk::radiobutton \
                ttk::scale \
                ttk::scrollbar \
                ttk::treeview \
        ]

        # Collect
        array set z {}
        foreach wg $widgets {
                $wg .wg
                foreach ol [.wg configure] {
                        lappend z([lindex $ol 0]) $wg
                }
                destroy .wg
        }

        # Sprackulate
        foreach wg [linsert $widgets 0 common] { set [string map {: _} $wg] {} }

        # Iplifiy
        foreach o [lsort [array names z]] {
                if {[llength $z($o)] == [llength $widgets]} {
                        lappend common $o
                } else {
                        foreach wg $z($o) { lappend [string map {: _} $wg] $o }
                }
        }

        catch {grid . -banana yellow} cow
        foreach moo [split $cow ,] { lappend grid [lindex [regexp -inline {^.*(-.+)$} $moo] 1] }

        # Plorfinize
        set M [menu $w.moptions -tearoff 0]
        foreach wg [linsert $widgets 0 common grid] {
                set m [menu $M.m[string map {: _} $wg] -tearoff 0]
                foreach i [set [string map {: _} $wg]] {
                        $m add command -label [string totitle $i] -command [list [namespace current]::insert [string map {: _} $i]]
                }
                $M add cascade -label [string totitle $wg] -menu $m
        }
        $M add separator
        $M add command -label "Close Menu"

        return $M
}
###



#
#
#
proc insert {what} {
        variable where
        $where insert insert "$what "
}
###



#
#
#
proc domenu {w m x y} {
        variable where $w
        tk_popup $m $x $y
}
###



#
#
#
proc about {} {
        catch {destroy .q}
        wm group [toplevel .q] .
        {*}[gub::gubProc [gub::gub "l\nl\nl\nb
.l0 -text {TkGub 0.2}
.l1 -text {Stuart Cassoff}
.l2 -text {Fall/Winter 2008}
.b0 -text Ok -command {destroy .q}
/b0 ok
" aboot] widget aboot]
        widget .q
        wm title .q "TkGub 0.2 - About"
        ::tk::PlaceWindow .q widget .
        variable aboot
        focus $aboot(ok)
        unset aboot
}
###



#
#
#
proc readme {} {
        set var readmeGUI
        catch {destroy .q}
        wm group [toplevel .q] .
        {*}[gub::gubProc [gub::gub "
f t s
  s
b
.b0 -text Ok -command {destroy .q}
.t0 -wrap none
.s1 -orient horizontal
:s0
:s1 -sticky ew
:f0
^s0 t0
=s1 t0
|f0
-f0
|.
-.
/t0 text
/b0 button
" $var] widget $var]
        widget .q
        wm title .q "TkGub 0.2 - Readme"
        variable $var
        [set ${var}(text)] insert end "TkGub 0.2

Stuart Cassoff
Fall/Winter 2008

<Button-3> for widget options

Widgets:
 b button                B ttk::button
 c canvas
 k checkbutton                K ttk::checkbutton
 e entry                E ttk::entry
 f frame                F ttk::frame
 l label                L ttk::label
 z labelframe                Z ttk::labelframe
 o listbox
 r radiobutton                R ttk::radiobutton
 y scale                Y ttk::scale
 s scrollbar                S ttk::scrollbar
 i spinbox
 t text
                X ttk::combobox
                N ttk::notebook
                V ttk::treeview

Line format:
Spacing is important.
Two (2) positions per widget.
Generally: widget ?tag? ?widget ?tag? ...?
wtwtwt
Tags can be empty:
w w w w
Put things in a frame (note the positioning):
f t s
  s

Options/Controls:
General form:
? == option/control described below
w == one of the above widget types
n == nth widget of type w
a == widget of type w tagged 'a'
d == option/parm/data (one or more)

?w d   For all w
?wn d  For nth w
?wa d  For w tagged 'a'

Tags are one char, user supplied.
Indexes (nth) are generated for
each widget type, starting at 0.

.  Widget options  ( .l0 -text Hello )
:  Grid options    ( :l0 -sticky nsew )
^  Scrollbar Ylink ( ^s0 t0 )
=  Scrollbar Xlink ( =s0 t0 )
|  Rowconfigure    ( |f0 0 -weight 1 )
-  Columnconfigure ( -f0 0 -weight 1 )
/  Save widget as  ( /t0 inputText )

Shortcuts:
:l0 same as :l0 -sticky nsew
|f0 same as |f0 0 -weight 1
-f0 same as -f0 0 -weight 1

Use '+' to apply an option/control to multiple widgets:
.b0+l0 -bg red
|f0+f1+f2
:t0+t1 -stricky nsew

Notes:
The tag of parent window is '.'.
'.' options aggregate, all others tend to override.
Lines starting with '#' and blank lines are ignored.
Lines can be joined with ';'.
"

        focus [set ${var}(button)]
        unset $var
}
###



#
#
#
proc Load {} {
        variable gui
        set fn [tk_getOpenFile]
        if {$fn eq ""} { return }
        $gui(in) delete 1.0 end
        $gui(in) insert end [read [set f [open $fn]]][close $f]
        gubrun
}
###



#
#
#
proc Save {} {
        variable gui
        set fn [tk_getSaveFile]
        if {$fn eq ""} { return }
        set f [open $fn w]
        puts -nonewline $f [$gui(in) get 1.0 end-1c]
        close $f
}
###



#
#
#
proc gubrun {} {
        variable gui
        $gui(out) delete 1.0 end

        if {[catch {
                $gui(out) insert end [gub::gubProc [gub::gub [$gui(in) get 1.0 end]]]
                run
        } err]} {
                $gui(out) delete 1.0 end
                $gui(out) insert end $::errorInfo
        }
        after 20 [list focus $gui(in)]
}
###


#
#
#
proc run {} {
        variable gui

        catch {destroy [set w $gui(w).test]}
        toplevel $w; bind $w <Control-q> exit; bind $w <Control-Q> exit

        eval [$gui(out) get 1.0 end-1c]
        widget $w
        after 20 [list focus $gui(out)]
}
###


gui


}; # End of tkgub namespace

# EOF