bdfedit

来自「Very very small GUI. Usefull for small s」· 代码 · 共 2,178 行 · 第 1/5 页

#!/usr/bin/wish -f
#Fix the path above.

# TTD
# BACKUP FILE BEFORE SAVE!!!!
# problem - setgrid doesn't handle metadata of char well:
#   it sets character data instead of just currchar data
#   e.g. name, dwidth
# to make it publishable:
#   defaults, .bdfeditrc (default size, default comment, default foundry...)
#
# display modified state (i.e. save needed or not)
# entry of proportional font info
#   drag right edge of font inward
# set up hint markers for marking grid (e.g. lower case ascent height)
# allow in-place editing of character name (instead of pop-up)
# help
#
# shift drag == OR
# control drag == XOR
# mode for swapping chars (including char names)
# drag FROM grid
# load font - interactive file selection
# support vertical fonts
# clear whole clipboard
# resize:
#   scale
#   max save
# support xmag/bitmap cut-n-paste selection
#
# select area
#   flip l-r, u-d
#   rotate 180
#   slide left, right, up, down, diagonals
#   invert
#   copy/paste
#   autotile
# 
# line
# circle
# rectangle
# flood fill
# undo
# paste (from X11)
# resize; rescale; alter baseline; alter margin
# 

proc completion_bindings {entry} {
  bind $entry <Tab> { path_expand %W; break }
  bind $entry <Escape> { popdown_list %W }
  bind $entry <slash> { popdown_list %W }
}

proc path_expand {entry} {
  popdown_list $entry
  #get the path we have so far
  set pathsofar [$entry get]
  if [string length $pathsofar]==0 {
    set startpath .
    set nextpath ""
  } else {
    set pathels [split $pathsofar /]
    set nextpath [lindex $pathels end]
    set chopat [expr [llength $pathels]-2]
    set newpathels [lrange $pathels 0 $chopat]
    set startpath [join $newpathels /]
  }
  if ![file isdirectory $startpath/] {
    bell
    return
  }
  if ![file readable $startpath/] {
    bell
    return
  }
  set pattern "$nextpath*"
  set kids [glob -nocomplain $startpath/*]
  set good ""
  foreach kid $kids {
    if [string match $startpath/$pattern $kid] {
      lappend good $kid
    }
  }
  if [llength $good]==0 {    # no matches
    bell
    return
  } elseif [llength $good]==1 {    # one match
    set show [string range $good [string length $pathsofar] end]
    if [file isdirectory $good] {
      $entry insert end $show/
    } else {
      $entry insert end $show
    }
  } else {    # more than one match
    $entry insert end [more_non_unique $pathsofar $good]
    popup_list $entry $good
    bell
  }
}

proc popdown_list {entry} {
  if [winfo exists .pe_popup] {
    .pe_popup unpost
  }
}

proc popup_list {entry list} {
  set list [lsort $list]
  if ![winfo exists .pe_popup] {
    menu .pe_popup -tearoff 0
  } else {
    .pe_popup delete 0 end   
  }
  set length [llength $list]
  set maxw 0
  set widest 0
  for {set i 0} {$i<$length} {incr i} {
    set w [string length [lindex $list $i]]
    if $w>$maxw {
      set maxw $w
      set widest $i
    }
  }
  if ($length<10) {
    set columns 1
  } elseif ($length<45) {
    set columns 2
  } elseif ($length<80) {
    set columns 3
  } elseif ($length<150) {
    set columns 4
  } elseif ($length<240) {
    set columns 5
  } else {
    set columns 6
  }
  set rows [expr int($length/$columns)]
  if [expr $length%$columns] { incr rows }
  set i 0
  set skippath [expr [string length [file dirname [lindex $list 0]]]+1]
  #special case for starting path of "/"
  if $skippath==2 { set skippath 1 }
  foreach item $list {
    set tmp [string range $item $skippath end]
    set type [file type $item]
    switch $type {
      file { if [file executable $item] { set tmp "$tmp*" } }
      link { set tmp "$tmp@" }
      directory { set tmp "$tmp/" }
      fifo { set tmp "$tmp|" }
      socket { set tmp "$tmp=" }
      characterSpecial { set tmp "$tmp%" }
      blockSpecial { set tmp "$tmp%" }
    }
    if [expr $i%$rows]==0 {
      .pe_popup add command -label $tmp -columnbreak 1 -command "$entry delete 0 end; $entry insert end $item"
    } else {
      .pe_popup add command -label $tmp -command "$entry delete 0 end; $entry insert end $item"
    }
    incr i
  }
  set x [winfo rootx $entry]
  set y [expr [winfo rooty $entry]+[winfo height $entry]]
  .pe_popup post $x $y
  #focus .bar
  #grab -global .bar
}

proc more_non_unique {start matchlist} {
  set nonunique [lindex $matchlist 0]
  set startlen [string length $start]
  foreach a $matchlist {
    for {set i [string length $nonunique]} {$i>=0} {incr i -1} {
      if {"[string range $a 0 $i]"=="[string range $nonunique 0 $i]"} {
        set nonunique [string range $nonunique 0 $i]
        break
      } 
    }
  }
  return [string range $nonunique $startlen end] 
}


set hex2bin(0) {0 0 0 0}
set hex2bin(1) {0 0 0 1}
set hex2bin(2) {0 0 1 0}
set hex2bin(3) {0 0 1 1}
set hex2bin(4) {0 1 0 0}
set hex2bin(5) {0 1 0 1}
set hex2bin(6) {0 1 1 0}
set hex2bin(7) {0 1 1 1}
set hex2bin(8) {1 0 0 0}
set hex2bin(9) {1 0 0 1}
set hex2bin(a) {1 0 1 0}
set hex2bin(b) {1 0 1 1}
set hex2bin(c) {1 1 0 0}
set hex2bin(d) {1 1 0 1}
set hex2bin(e) {1 1 1 0}
set hex2bin(f) {1 1 1 1}
foreach key [array names hex2bin] {
  set bin2hex($hex2bin($key)) $key
}
set hex2bin(A) {1 0 1 0}
set hex2bin(B) {1 0 1 1}
set hex2bin(C) {1 1 0 0}
set hex2bin(D) {1 1 0 1}
set hex2bin(E) {1 1 1 0}
set hex2bin(F) {1 1 1 1}

set default(WIDTH) 9
set default(HEIGHT) 12
set default(DESCENT) -3
set default(COMMENT) {
 This font is copyrighted by its author, who reserves all rights under
 national and international copyright laws.

 Produced with bdfedit, a tcl/tk font editing program
   written by Thomas A. Fine
   [e-mail]
   http://hea-www.harvard.edu/~fine/
}

set GPAD 20
set GTOP 200
set GLEFT 60
set GMARGIN 1
set GBOX 12
set FLEFT 15
set FRIGHT 30
set FTOP 15
set FBOTTOM 30

set resize(gsz) 10
set resize(gleft) 50
set resize(gtop) 50
set holdserial(last) 0
set pickstate ""

set BG #00BE74
set currfile ""
. config -bg $BG
option add *[tk appname]*background $BG 90

frame .top -bd 2 -relief raised
pack .top -fill x
menubutton .top.file -text File -menu .top.file.m -underline 0
menu .top.file.m
.top.file.m add command -label New -command new
.top.file.m add command -label Load -command load
.top.file.m add command -label Save -command save
.top.file.m add command -label "Save As" -command saveas
.top.file.m add separator
.top.file.m add command -label Properties -command properties
.top.file.m add command -label "Edit Comment" -command comment
.top.file.m add command -label Resize -command resize
.top.file.m add command -label "Convert to Fixed" -command fixall
.top.file.m add separator
.top.file.m add command -label Quit -command exit
pack .top.file -side left
menubutton .top.edit -text Edit -menu .top.edit.m -underline 0
menu .top.edit.m
.top.edit.m add command -label "Flip up/down" -command flipud
.top.edit.m add command -label "Flip left/right" -command fliplr
.top.edit.m add command -label "Rotate 180" -command rot180
.top.edit.m add command -label "Invert black/white" -command invert
pack .top.edit -side left
label .top.fname -font fixed -textvar currfile
pack .top.fname -side right

#using two canvas vastly speeds things up, because when you try to change the
#grid rectangles, you aren't searching through the thousands of objects
#created to draw the entire font
canvas .fc -width 500 -height 200 -bg white -highlightthickness 0
pack .fc
canvas .c -width 500 -height 300 -bg white -highlightthickness 0
pack .c

button .c.clear -text Clear -command clearwork -highlightthickness 0 -padx 1 -pady 1
button .c.apply -text Apply -command applywork -highlightthickness 0 -padx 1 -pady 1
button .c.reset -text Reset -command resetwork -highlightthickness 0 -padx 1 -pady 1
button .c.orig -text Orig -command origwork -highlightthickness 0 -padx 1 -pady 1
button .c.hold -text Hold -command {hold work} -highlightthickness 0 -padx 1 -pady 1

proc resetall {} {
  global WIDTH HEIGHT chardata fontinfo origdata holddata holdserial
  global FLEFT FTOP FRIGHT FBOTTOM
  
  set WIDTH 0
  set HEIGHT 0
  foreach elem [array names fontinfo] {
    unset fontinfo($elem)
  }
  foreach elem [array names chardata] {
    unset chardata($elem)
  }
  foreach elem [array names origdata] {
    unset origdata($elem)
  }
  #don't delete hold data - it gets resized by new and loadbdffont

  .c delete all
  .fc delete all
  set fontinfo(foundry) "Fine"
  set fontinfo(family) ""
  set fontinfo(weight) "Medium"
  set fontinfo(slant) "R"
  set fontinfo(widthname) "Normal"
  set fontinfo(copyright) "Designer of this font retains full rights under the law"
  set holdserial(last) 0
}

#convert font to fixed-width
proc fixall {} {
  global chardata WIDTH
  for {set encod 0} {$encod<256} {incr encod} {
    if ([info exists chardata($encod)]) {
      set chardata(dwidth,$encod) $WIDTH
    }
  }
}

proc properties {} {
  showprops
  wm deiconify .propdialog
  grab .propdialog
}

proc showprops {} {
  global proplist fontinfo
  .propdialog.labels config -state normal
  .propdialog.labels delete 0.0 end
  .propdialog.values delete 0.0 end
  set maxval 0
  set maxlab 0
  foreach prop $proplist {
    .propdialog.labels insert insert "$prop\n"
    .propdialog.values insert insert "$fontinfo($prop)\n"
    if [string length $fontinfo($prop)]>$maxval {
      set maxval [string length $fontinfo($prop)]
    }
    if [string length $prop]>$maxlab {
      set maxlab [string length $prop]
    }
  }
  .propdialog.values config -width $maxval
  .propdialog.labels config -width $maxlab -state disabled
}

proc setpropwidth {} {
  set numlines [.propdialog.values index "end -1l"]
  set winwidth [.propdialog.values cget -width]
  set max 0
  for {set i 1} {$i<$numlines} {incr i} {
    scan [.propdialog.values index $i.end] %d.%d linenum linewidth
    if $linewidth>$max { set max $linewidth }
  }
  #we really want to be doing this function after the current key event is
  #processed, but its simpler just to add a fudge to the needed with to
  #make sure the text will always fit:
  #(adding 2 instead of 1 prevents jitter (text wrap, unwrap after resize))
  incr max 2
  if (($max>$winwidth)||($max<$winwidth&&$max>=10)) {
    .propdialog.values config -width $max
  }
}

proc changeprops {} {
  global proplist fontinfo
  set line 1
  foreach prop $proplist {
    set fontinfo($prop) [.propdialog.values get $line.0 $line.end]
    incr line
  }
  wm withdraw .propdialog
  grab release .propdialog
}

proc comment {} {
  global fontinfo default
  .commdialog.t delete 0.0 end
  if ![info exists fontinfo(COMMENT)] {
    set fontinfo(COMMENT) $default(COMMENT)
  }
  .commdialog.t insert 0.0 $fontinfo(COMMENT)
  #this creates an extra blank line at the end, so get rid of it
  .commdialog.t delete "end -1 line lineend" end
  wm deiconify .commdialog
  grab .commdialog
}

proc changecomment {newcomm} {
  global fontinfo
  set fontinfo(COMMENT) [.commdialog.t get 0.0 end]
  wm withdraw .commdialog
  grab release .commdialog
}

proc resize {} {
  global resize WIDTH HEIGHT

  set resize(gsz) 10
  set w [expr $WIDTH*$resize(gsz)+20*$resize(gsz)]
  set h [expr $HEIGHT*$resize(gsz)+20*$resize(gsz)]
  if ($w<300) { set w 300 }
  if ($h<300) { set h 300 }
  set resize(gleft) [expr 10*$resize(gsz)]
  set resize(gtop) [expr 10*$resize(gsz)]
  .resizedialog.c config -width $w -height $h
  wm deiconify .resizedialog
  grab .resizedialog
  update
  drawresizer
}

proc new {} {
  wm deiconify .newdialog
  grab .newdialog
}

proc load {} {
  wm deiconify .loaddialog
  grab .loaddialog
}

proc save {} {
  global currfile
  if [string length $currfile] {
    dosave $currfile
  } else {
    saveas
  }
}

proc saveas {} {
  wm deiconify .savedialog
  grab .savedialog