
#@package: neosoft:font1 neosoft:font1:create_font_selector neosoft:font1:crack_fonts

package require Neo
package require Tk

#
# Copyright (C) 1992-1997 NeoSoft.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  NeoSoft makes no 
# representations about the suitability of this software for any purpose.
# It is provided "as is" without express or implied warranty.

#
# $Id: fonts.tcl,v 1.1.1.1 1999/03/31 20:34:39 damon Exp $
#

#font family
#    point size
#        family
#        weight
#        slant
#        width
#        style

proc neosoft:font1:set_font_defaults {w} {
    $w.font_name delete 0 end
    $w.font_name insert end "new century schoolbook"

    $w.font_size delete 0 end
    $w.font_size insert end 10

    $w.font_info delete 0 end
    $w.font_info insert end "adobe medium i normal"
}

proc neosoft:font1:get_current_font_string {w} {
    set fontName [$w.font_name get]
    set pixelSize [$w.font_size get]
    assign_fields [$w.font_info get] foundry weight slant width

    return [join [list "" $foundry $fontName $weight $slant $width "" $pixelSize *] "-"]
}


proc neosoft:font1:create_font_tag {w textWidget} {
    set tagName [neosoft:font1:get_current_font_string $w]
    $textWidget tag configure $tagName -font $tagName

    return $tagName
}

# additional fields in assign_fields would be
# pointSize xResolution yResolution spacing averageWidth 
# registry encoding
 
proc neosoft:font1:crack_fonts {} {
    global fontPoints fontInfo

    for_file line "|xlsfonts" {
        assign_fields [split $line "-"] \
            dummy foundry family weight slant width style pixelSize 

        if [info exists fontPoints($family)] {
            if {[lsearch $fontPoints($family) $pixelSize] < 0} {
                lappend fontPoints($family) $pixelSize
            }
        } else {
            set fontPoints($family) $pixelSize
        }

        lappend fontInfo($family:$pixelSize) \
            [list $foundry $weight $slant $width]
    }
}

proc neosoft:font1:dump_fonts {} {
    global fontPoints fontInfo

    foreach family [array names fontPoints] {
        
        set points [lsort $fontPoints($family)]
        echo '$family' $points
        foreach size $points {
            echo "    $fontInfo($family:$size)"
        }
    }
}

proc neosoft:font1:create_font_selector {w} {
    global fontPoints fontInfo
    global NEOSOFT_ENV

    set dropBitmap $NEOSOFT_ENV(desktopBitmaps)/standard/Down

    frame $w

    label $w.name_label -text "Font"
    entry $w.font_name -relief raised -width 20
    button $w.drop_font_button -bitmap @$dropBitmap -command "neosoft:font1:drop_fontlist $w"
    pack $w.name_label -side left
    pack $w.font_name -side left
    pack $w.drop_font_button -side left

    label $w.size_label -text "Size"
    entry $w.font_size -relief raised -width 3
    button $w.drop_size_button -bitmap @$dropBitmap -command "neosoft:font1:drop_fontsizelist $w"
    pack $w.size_label -side left
    pack $w.font_size -side left
    pack $w.drop_size_button -side left

    label $w.info_label -text "Characteristics"
    entry $w.font_info -relief raised -width 30
    button $w.drop_info_button -bitmap @$dropBitmap -command "neosoft:font1:drop_fontinfolist $w"
    pack $w.info_label -side left
    pack $w.font_info -side left
    pack $w.drop_info_button -side left

    neosoft:font1:set_font_defaults $w
    return $w
}

proc neosoft:font1:drop_fontlist {w} {
    global fontPoints
    set font [list_listbox_subwindow .fontlist "Please pick a font." \
        20x10 [lsort [array names fontPoints]]]
    $w.font_name delete 0 end
    $w.font_name insert 0 $font
}

proc neosoft:font1:drop_fontsizelist {w} {
    global fontPoints
    set fontName [$w.font_name get]
    if ![info exists fontPoints($fontName)] {
        modal_dialog "I know of no font named '$fontName'" Cancel
        return
    }
    set pixelSizeList $fontPoints($fontName)
    set pixelSize [list_listbox_subwindow .fontlist \
        "Please pick a point size." \
        5x5 [lsort $pixelSizeList]]
    $w.font_size delete 0 end
    $w.font_size insert 0 $pixelSize
}

proc neosoft:font1:drop_fontinfolist {w} {
    global fontInfo fontPoints

    set fontName [$w.font_name get]
    if ![info exists fontPoints($fontName)] {
        modal_dialog "I know of no font named '$fontName'" Cancel
        return
    }

    set pixelSize [$w.font_size get]

    set indexName $fontName:$pixelSize
    if ![info exists fontInfo($indexName)] {
        modal_dialog "I have no font named '$fontName' at a pixel size of '$pixelSize'." Cancel
        return
    }

    set pointInfoList $fontInfo($indexName)
    set pointInfo [list_listbox_subwindow .fontlist \
        "Please select font characteristics." \
        35x4 [lsort $pointInfoList]]
    $w.font_info delete 0 end
    $w.font_info insert 0 $pointInfo
}


