#
# Lipsum color : a color chooser for foreground / background
# version 1.1
#
# Largely Adapted from colordemo.tcl 
# Copyrights : 
#      2003 Vincent Wartelle
#      1996 Jeffrey Hobbs
#      1996 University of Oregon. Spencer Smith
#
# The font chooser uses Bryan Oakley's combobox: 
#       see http://www2.clearlight.com/~oakley/tcl/combobox/
#
# The short font list comes from Chuck Upsdell's page
#   http://www.upsdell.com/BrowserNews/res_fonts.htm
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
#  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE. 
#

#   Global variables
#   FGCOLOR     array of the current foreground color : entries rgb, red, green, blue
#   BGCOLOR     array of the current foreground color : entries rgb, red, green, blue
#   TARGET      current target to colorize (left, top, button, center)
#   PATHTARGET  each graphic path is associated a target
#   TARGETPATH  a list of graphic paths associated to a target
#   ENTFGCOLOR  foreground color associated to the entry field
#   ENTBGCOLOR  background color associated to the entry field
#   AUXID       identifier of an auxiliary window
#   AUXWIDTH    width of the current auxiliary window
#
#   Global variables for current font definition
#   SIZE        font size
#   FONTFAMILY  characteristics of a font (category, type, family)
#   FONTCAT     font category (Core, Win, Mac, Ux)
#   FONTTYPE    font type (Serif, Sans-serif, Monospace, Cursive)
#   FAMILY      font family
#   SLANT       slant of the font
#   WEIGHT      weight of the font
#   UNDERLINE   1 if font underlined
#   OVERSTRIKE  1 if font overstriked

#   build an approximate square with seven buttons associated to four targets
proc build_square { path } {

    pack [frame $path.left] -side left -anchor n -fill y

    button $path.top -bg "#F0F0FF" -fg "#808080" -text "adipisicing elit,"
    button $path.center -bg "#8F97FF" -fg "#FFE0E4"  -justify right -text \
    "sed do eiusmod \n\
     tempor incididunt ut \n\
     labore et dolore magna \n\
     aliqua. Ut enim ad minim veniam, \n\
     quis ostrud exercitation ullamco \n\
     laboris nisi ut aliquip ex\n\
     ea commodo consequat. Duis \n\
     aute irure dolor in reprehenderit\n\
     in voluptate velit esse cillum \n\
     dolore eu fugiat nulla pariatur. \n\
     Excepteur sint occaecat cupidatat\n\
     non proident, sunt in culpa qui \n\
     officia deserunt mollit anim id\n\
     est laborum."


    pack $path.top -side top -anchor center -fill x 
    pack $path.center -side top -anchor center -expand yes -fill both 

    button $path.left.b1  -bg "#B0C4DE" -fg "#FFFFFF" 
    pack $path.left.b1 -side top -anchor n -fill x 

    button $path.left.b2  -bg "#4682B4" -fg "#F0F0F0" -text "Lorem ipsum"
    pack $path.left.b2 -side top -anchor n -fill x 

    button $path.left.b3  -bg "#B0C4DE" -fg "#FFFFFF" 
    pack $path.left.b3 -side top -anchor n -fill x 

    button $path.left.b4  -bg "#4682B4" -fg "#F0F0F0" -text "dolor sit amet"
    pack $path.left.b4 -side top -anchor n -fill x 

    button $path.left.b5  -bg "#B0C4DE" -fg "#FFFFFF" -text "consectetur"
    pack $path.left.b5 -side top -anchor n -expand yes -fill both 

    frame $path.down 
    pack $path.down -side bottom -anchor s -fill x 
    button $path.down.ad -bg "#F0F0FF" -fg "#808080" -text "www.oklin.com"
    pack $path.down.ad -side top -anchor s -fill x 

    foreach widget [list $path.top $path.center $path.left.b1 $path.left.b3 \
                    $path.left.b5 $path.left.b2 $path.left.b4 $path.down.ad] {
        $widget configure -command "click $widget"
    }


    set ::TARGETPATH(left) [list $path.left.b1 $path.left.b3 $path.left.b5]
    set ::TARGETPATH(top) [list $path.top $path.down.ad]
    set ::TARGETPATH(button) [list $path.left.b2 $path.left.b4]
    set ::TARGETPATH(center) $path.center

    foreach { but targ } {b1 left b3 left b5 left b2 button b4 button } {
        set ::PATHTARGET($path.left.$but) $targ
    }
    set ::PATHTARGET($path.top) top
    set ::PATHTARGET($path.down.ad) top
    set ::PATHTARGET($path.center) center
}


#   callback when a button is clicked
proc click { widget } {
    set ::FGCOLOR(rgb) [$widget cget -fg]
    set ::BGCOLOR(rgb) [$widget cget -bg]
    set ::TARGET $::PATHTARGET($widget)
    set_bgcolor $::BGCOLOR(rgb)
    set_fgcolor $::FGCOLOR(rgb)
    .top.lm.but config -font [$widget cget -font]
    update
}

#   is this a valid rgb color
proc is_validcolor { rgb } {
    if { [string length $rgb] == 7 && [string is xdigit [string range $rgb 1 end]] } {
        return 1
    } else {
        return 0
    }
}

#   set the background color of the current target
proc set_bgcolor {{rgb {}}} {   
    if [string comp {} $rgb]  {
        scan $rgb "\#%2x%2x%2x" red green blue
        foreach c {red green blue} { set ::BGCOLOR($c) [format %d [set $c]] }
    } else {
        set rgb \#[format "%.2X%.2X%.2X" $::BGCOLOR(red) $::BGCOLOR(green) $::BGCOLOR(blue)]
    }
    foreach path $::TARGETPATH($::TARGET) {
        $path config -bg $rgb
    }
    .top.lm.but config -bg $rgb
    set ::BGCOLOR(rgb) $rgb
    set ::ENTBGCOLOR $::BGCOLOR(rgb)
    update
}

#   set the foreground color of the current target
proc set_fgcolor {{rgb {}}} {
    if [string comp {} $rgb] {
        scan $rgb "\#%2x%2x%2x" red green blue
        foreach c {red green blue} { set ::FGCOLOR($c) [format %d [set $c]] }
    } else {
        set rgb \#[format "%.2X%.2X%.2X" $::FGCOLOR(red) $::FGCOLOR(green) $::FGCOLOR(blue)]
    }
    foreach path $::TARGETPATH($::TARGET) {
        $path config -fg $rgb
    }
    .top.lm.but config -fg $rgb
    set ::FGCOLOR(rgb) $rgb
    set ::ENTFGCOLOR $::FGCOLOR(rgb)
    update
}

#   set the font of the current target
proc set_targetfont { fontinfo } {
    set goodfont [catch {set tmpfont [eval font create $fontinfo]}]
    if { $goodfont == 0 } {
        foreach path $::TARGETPATH($::TARGET) {
            $path config -font $tmpfont
        }
    }
}

#   callbacks to scale widgets
proc set_bgcolor_aux args { set_bgcolor }
proc set_fgcolor_aux args { set_fgcolor }

#   update ENTBGCOLOR ( when entry is changed)
proc update_entbgcolor { args } {    
    if { $::ENTBGCOLOR == $::BGCOLOR(rgb) } {
        return
    } else {
        if [is_validcolor $::ENTBGCOLOR] {
            set_bgcolor $::ENTBGCOLOR
        }
    }
}
#   update ENTFGCOLOR ( when entry is changed)
proc update_entfgcolor { args } {    
    if { $::ENTFGCOLOR == $::FGCOLOR(rgb) } {
        return
    } else {
        if [is_validcolor $::ENTFGCOLOR] {
            set_fgcolor $::ENTFGCOLOR
        }
    }
}

#   get the font information of a widget
#   don't display default values
proc get_fontinfo { w } {
    set fontinfo [font actual [$w cget -font]]
    set reslist {}
    foreach { opt value } $fontinfo {
        set optcode [string range $opt 1 end]
        switch -exact $optcode {
            slant   { if { $value != "roman" } {
                        lappend reslist $opt $value         
                    }
            }
            weight  { if { $value != "normal" } {
                        lappend reslist $opt $value         
                    }
            }
            underline  { if { $value != 0 } {
                        lappend reslist $opt $value         
                    }
            }
            overstrike  { if { $value != 0 } {
                        lappend reslist $opt $value         
                    }
            }        
            default {
                lappend reslist $opt $value         
            }
        }
    
    
    }
    return $reslist
}

#   return in a short text the choosen colors and font
#   set AUXWIDTH (width of the auxiliary window) to max line width
proc display_colorsandfont {} {
    set rettext ""
    set ::AUXWIDTH 0
    foreach target [array names ::TARGETPATH] {
        set firstw [lindex $::TARGETPATH($target) 0]
        set word $target
        while { [string length $word] < 7 } { append word " " } 
        set targetline "$word [$firstw cget -bg] [$firstw cget -fg] [get_fontinfo $firstw]\n"  
        if { [string length $targetline] > $::AUXWIDTH } {
            set ::AUXWIDTH [string length $targetline] 
        }
        append rettext $targetline
    }
    return $rettext
}

#   set the colors and font from a text widget
proc set_colorsandfont { texw } {
    set colortext [$texw get 1.0 end]
    foreach line [split $colortext \n] {
        set firstw [lindex $line 0]
        if { [info exist ::TARGETPATH($firstw)] } {
            set ::TARGET $firstw
            if { [is_validcolor [lindex $line 1]] } {
                set_bgcolor [lindex $line 1]
            }
            if { [is_validcolor [lindex $line 2]] } {
                set_fgcolor [lindex $line 2]
            }
            set_targetfont [lrange $line 3 end]
        }
    }    
}

#   auxiliary text window
proc aux_window {} {
    set ::AUXID 1
    while { [winfo exists .w[set ::AUXID]] } {
        incr ::AUXID
    }
    set aux [toplevel .w[set ::AUXID]]
    wm resizable $aux 1 1
    wm title $aux "lipsumcolor $::AUXID"
    pack [text $aux.text -width 20 -height 5] -side top -expand yes -fill both
    $aux.text configure -font {Courier 9}
    $aux.text insert 1.0 [display_colorsandfont]
    $aux.text configure -width $::AUXWIDTH
    pack [frame $aux.down] -side bottom -fill x
    button $aux.down.but -text "Set" -width 12 -command "set_colorsandfont $aux.text"
    button $aux.down.quit -text "Close" -width 12 -command "destroy $aux"
    pack  $aux.down.quit $aux.down.but -side right -padx 4 -pady 4    
}

#   add the button to call auxiliary window
proc add_auxbutton {} {
    image create photo text1 -data {
    R0lGODdhEAAQAPf/AO7u7jMzM////87W3t7e3gAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAACH5BAEAAAYALAAAAAAQABAABwhqAA0EGEhwoIGD
    CAUKWMhQQAABCQ8+bLiQYMSHBQMA2BjgYsOMBSUCKEixIkSNG0eWdEhwJEGW
    LTmi5EgxpUuXA3EWvJlypk2OAneC1NgxoU8CSJEWRRiAwFCnF5MSGECV6lKE
    BbJq1WogIAA7
    }
    pack [button .top.lm.middle.but -image text1 -command "aux_window"]
}

#
# Lipsumcolor font chooser
#
# Adapted from : "A simple font display utility." 
# Example of the combobox utility (B.Oakley)
# 
# This program uses two variations of the combobox. One, for the font
# family, is non-editable (ie: the user can only pick from the list). 
# The other, for font size, is editable. The user can pick from the list 
# or enter their own size


#   make a short font list with category, type, family
proc make_fontlist {} {

    set ::fontlist {
        { Core | Monospace  | Andale Mono}
        { Core | Sans-serif | Arial}
        { Core | Sans-serif | Arial Black}
        { Win  | Serif      | Book Antiqua}
        { Win  | Serif      | Bookman Old Style}
        { Win  | Serif      | Calisto MT}
        { Win  | Sans-serif | Century Gothic}
        { Mac  | Sans-serif | Charcoal}
        { Mac  | Serif      | Chicago}
        { Core | Cursive    | Comic Sans MS}
        { Mac  | Monospace  | Courier}
        { Ux   | Monospace  | Courier}
        { Core | Monospace  | Courier New}
        { Win  | Serif      | Garamond}
        { Mac  | Sans-serif | Geneva}
        { Core | Serif      | Georgia}
        { Mac  | Sans-serif | Helvetica}
        { Ux   | Sans-serif | Helvetica}
        { Core | Sans-serif | Impact}
        { Ux   | Sans-serif | LUxi Sans}
        { Ux   | Monospace  | LUxi Mono}
        { Ux   | Serif      | LUxi Serif}
        { Mac  | Monospace  | Monaco}
        { Win  | Cursive    | Monotype Corsiva}
        { Ux   | Serif      | New Century Schoolbook}
        { Win  | Sans-serif | News Gothic MT}
        { Mac  | Serif      | New York}
        { Mac  | Serif      | Palatino}
        { Win  | Sans-serif | Tahoma}
        { Mac  | Serif      | Times}
        { Ux   | Serif      | Times}
        { Core | Serif      | Times New Roman}
        { Core | Sans-serif | Trebuchet}
        { Ux   | Serif      | Utopia}
        { Core | Sans-serif | Verdana}
    }
}

#   return the font family from an item of the above list
proc get_fontfromitem { item } {
    return [string range [lindex [split $item |] 2] 1 end]
}

#   the font chooser window
proc font_chooser { w } {
    # don't create if window exists
    if { [winfo exists $w] } {
        wm deiconify $w
        return
    }

    toplevel $w
    make_fontlist

    # default values
    set ::SIZE       12
    set ::FONTFAMILY [lindex $::fontlist 1]
    set ::SLANT      roman
    set ::WEIGHT     normal
    set ::OVERSTRIKE 0
    set ::UNDERLINE  0

    wm title $w "Lipsumcolor font ..."

    # the main two areas: a frame to hold the font picker widgets
    # and a label to display a sample from the font
    set fp [frame $w.fontpicker]
    set msg [label $w.msg -borderwidth 2 -relief groove -width 30 -height 4]

    pack $fp -side top -fill x
    pack $msg -side top -fill both -expand y -pady 2

    $msg configure -text [join [list \
        "ABCDEFGHIJKLMNOPQRSTUVWXYZ" \
        "abcdefghijklmnopqrstuvwxyz" \
        "0123456789~`!@#$%^&*()_-+=" \
        "{}[]:;\"'<>,.?/"] "\n"]

    # this will set the font of the message according to our defaults
    local_changefont $msg

    # font family...
    label $fp.famLabel -text "Font Family:"
    combobox $fp.famCombo \
        -textvariable FONTFAMILY \
        -editable false \
        -highlightthickness 1 \
        -font { "Courier" 9 } \
        -command change_font
        
        # -font { "Courier" 9 } 

    pack $fp.famLabel -side left
    pack $fp.famCombo -side left -fill x -expand y


    # insert font list
    # we'll do these one at a time so we can find the widest one and
    # set the width of the combobox accordingly 
    set widest 0
    foreach fontitem $::fontlist {
        if { [lsearch [font families] [get_fontfromitem $fontitem] ] != -1 } {
            if {[set length [string length $fontitem]] > $widest} {
                set widest $length
            }
            $fp.famCombo list insert end $fontitem
        }
    }
    $fp.famCombo configure -width $widest

    # the font size. We know we are puting a fairly small, finite
    # number of items in this combobox, so we'll set its maxheight
    # to zero so it will grow to fit the number of items
    label $fp.sizeLabel -text "Font Size:"
    combobox $fp.sizeCombo \
        -highlightthickness 1 \
        -maxheight 0 \
        -width 3 \
        -textvariable SIZE \
        -editable true \
        -command change_font

    pack $fp.sizeLabel -side left
    pack $fp.sizeCombo -side left
    eval $fp.sizeCombo list insert end [list 8 9 10 12 14 16 18 20 24 28 32 36]

    # a dummy frame to give a little spacing...
    frame $fp.dummy -width 5
    pack $fp.dummy -side left

    # bold
    set bold "bold"
    checkbutton $fp.bold -variable WEIGHT -indicatoron false \
        -onvalue bold -offvalue normal \
        -text "B" -width 2 -height 1 \
        -font {-weight bold -family Times -size 10} \
        -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
        -command change_font
    pack $fp.bold -side left

    # underline
    checkbutton $fp.underline -variable UNDERLINE -indicatoron false \
        -onvalue 1 -offvalue 0 \
        -text "U" -width 2 -height 1 \
        -font {-underline 1 -family Times -size 10} \
        -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
        -command change_font
    pack $fp.underline -side left

    # italic
    checkbutton $fp.italic -variable SLANT -indicatoron false \
        -onvalue italic -offvalue roman \
        -text "I" -width 2 -height 1 \
        -font {-slant italic -family Times -size 10} \
        -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
        -command change_font
    pack $fp.italic -side left

    # overstrike
    checkbutton $fp.overstrike -variable OVERSTRIKE -indicatoron false \
        -onvalue 1 -offvalue 0 \
        -text "O" -width 2 -height 1 \
        -font {-overstrike 1 -family Times -size 10} \
        -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
        -command change_font
    pack $fp.overstrike -side left 

    # put focus on the first widget
    catch {focus $fp.famCombo}

    return ""
}

#   this proc changes the font of a widget
proc local_changefont {w args} {
    foreach foo [list FONTFAMILY SIZE WEIGHT UNDERLINE SLANT OVERSTRIKE] {
    if {[set ::$foo] == ""} {
        return
    }
    set ::FONTCAT [lindex [split $::FONTFAMILY |] 0]
    set ::FONTTYPE [lindex [split $::FONTFAMILY |] 1]
    set ::FAMILY [string range [lindex [split $::FONTFAMILY |] 2] 1 end]
    }
    set ::fontspec [list \
        -family     $::FAMILY \
        -size       $::SIZE \
        -weight     $::WEIGHT \
        -underline  $::UNDERLINE \
        -slant      $::SLANT \
        -overstrike $::OVERSTRIKE \
    ]
    $w configure -font $::fontspec
}

#   this proc changes the fonts of the appropriated widgets
#   in lipsumcolor, and in the font chooser message too
proc change_font { args } {
    local_changefont .fc.msg $args
    foreach path $::TARGETPATH($::TARGET) {
        local_changefont $path $args
    }
    local_changefont .top.lm.but $args
}

#   if combobox is available, the font button becomes active
proc activate_fontchooser {} {
    global auto_path
    #   try to source local "combobox.tcl"
    catch {source combobox.tcl}
    
    #   auto_path : append the place where combobox is stored
    #   (virtual directory, if wrapped with freewrap)
    if { [lsearch $auto_path "/vincent/tcl/combobox221"] == -1 } {
        lappend auto_path "/vincent/tcl/combobox221"
    }    
    set hascombo [catch { package require combobox 2.2 }]
    
    if { $hascombo == 0 } {    
        catch {namespace import combobox::*}
        .top.lm.but configure -text "Lorem ipsum font..." \
            -command "font_chooser .fc" -relief raised
    }
        
}

#   END OF FONT CHOOSER

#   main procedure
proc main {} {
    option add *Button.borderWidth 2 widgetDefault
    option add *Button.relief raised widgetDefault
    
    wm title . "lipsumcolor 1.1"
    destroy .top    

    pack [frame .top] -fill both -expand 1
    # .top.lm : lm means "left middle"
    pack [frame .top.lm] -side left -fill both
    pack [button .top.lm.but -text "Lorem ipsum" -relief flat] -side top 
    pack [frame .top.lm.left] -side left -fill both
    pack [frame .top.lm.middle] -side left -fill both 
    pack [frame .top.right] -side left -fill both -expand 1
    build_square .top.right    

    set arg {-from 0 -to 255 -showvalue 1 -orient horizontal}
    foreach i {red green blue} {
    eval scale .top.lm.left.$i $arg -var ::BGCOLOR($i) -troughcolor $i \
     -command set_bgcolor_aux
    pack .top.lm.left.$i -fill y -expand 1

    set ::FGCOLOR($i) 0
    eval scale .top.lm.middle.$i $arg -var ::FGCOLOR($i) -troughcolor $i \
     -command set_fgcolor_aux
    pack .top.lm.middle.$i -fill y -expand 1

    }

    pack [entry .top.lm.left.cname -width 8 -textvar ::ENTBGCOLOR] -pady 2
    bind  .top.lm.left.cname <KeyRelease> update_entbgcolor
    pack [entry .top.lm.middle.fgcname -width 8 -textvar ::ENTFGCOLOR] -side left
    bind .top.lm.middle.fgcname <KeyRelease> update_entfgcolor
    add_auxbutton
    click .top.right.top
    activate_fontchooser
    return
}


#   let's do it !
main