bdfedit

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

#
#

proc on {x y} {
  global GTOP GLEFT GMARGIN GBOX HEIGHT
  global chardata currchar
  .c itemconfig $x,$y -fill black
  set chardata(work) [lreplace $chardata(work) $y $y [lreplace [lindex $chardata(work) $y] $x $x 1]]
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc off {x y} {
  global GTOP GLEFT GMARGIN GBOX HEIGHT
  global chardata currchar
  .c itemconfig $x,$y -fill white
  set chardata(work) [lreplace $chardata(work) $y $y [lreplace [lindex $chardata(work) $y] $x $x 0]]
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc toggle {x y} {
  global GTOP GLEFT GMARGIN GBOX HEIGHT
  global chardata currchar
  if [lindex [lindex $chardata(work) $y] $x] {
    .c itemconfig $x,$y -fill white
    set chardata(work) [lreplace $chardata(work) $y $y [lreplace [lindex $chardata(work) $y] $x $x 0]]
  } else {
    .c itemconfig $x,$y -fill black
    set chardata(work) [lreplace $chardata(work) $y $y [lreplace [lindex $chardata(work) $y] $x $x 1]]
  }
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc slidedown {} {
  global GTOP GLEFT GBOX HEIGHT
  global chardata currchar
  set last [expr $HEIGHT-1]
  set row [lindex $chardata(work) $last]
  set chardata(work) [lreplace $chardata(work) $last $last]
  set chardata(work) [linsert $chardata(work) 0 $row]
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc slideup {} {
  global GTOP GLEFT GBOX HEIGHT
  global chardata currchar
  set row [lindex $chardata(work) 0]
  set chardata(work) [lreplace $chardata(work) 0 0]
  lappend chardata(work) $row
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc slideright {} {
  global GTOP GLEFT GBOX HEIGHT WIDTH
  global chardata currchar
  set newdata ""
  set last [expr $WIDTH-1]
  foreach row $chardata(work) {
    set bit [lindex $row $last]
    set row [lreplace $row $last $last]
    set row [linsert $row 0 $bit]
    lappend newdata $row
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc slideleft {} {
  global GTOP GLEFT GBOX HEIGHT
  global chardata currchar
  set newdata ""
  foreach row $chardata(work) {
    set bit [lindex $row 0]
    set row [lreplace $row 0 0]
    lappend row $bit
    lappend newdata $row
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc flipud {} {
  global GTOP GLEFT GBOX WIDTH HEIGHT
  global chardata currchar
  set newdata ""
  for {set j [expr $HEIGHT-1]} {$j>=0} {incr j -1} {
    lappend newdata [lindex $chardata(work) $j]
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc fliplr {} {
  global GTOP GLEFT GBOX WIDTH HEIGHT
  global chardata currchar
  set newdata ""
  for {set j 0} {$j<$HEIGHT} {incr j} {
    set row [lindex $chardata(work) $j]
    set newrow ""
    for {set i [expr $WIDTH-1]} {$i>=0} {incr i -1} {
      lappend newrow [lindex $row $i]
    }
    lappend newdata $newrow
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc rot180 {} {
  global GTOP GLEFT GBOX WIDTH HEIGHT
  global chardata currchar
  set newdata ""
  for {set j [expr $HEIGHT-1]} {$j>=0} {incr j -1} {
    set row [lindex $chardata(work) $j]
    set newrow ""
    for {set i [expr $WIDTH-1]} {$i>=0} {incr i -1} {
      lappend newrow [lindex $row $i]
    }
    lappend newdata $newrow
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc invert {} {
  global GTOP GLEFT GBOX WIDTH HEIGHT
  global chardata currchar
  set newdata ""
  for {set j 0} {$j<$HEIGHT} {incr j} {
    set row [lindex $chardata(work) $j]
    for {set i 0} {$i<$WIDTH} {incr i} {
      set row [lreplace $row $i $i [expr abs([lindex $row $i]-1)]]
    }
    lappend newdata $row
  }
  set chardata(work) $newdata
  setgrid chardata work
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $chardata(work) view
}

proc blankchar {width height} {
  set data ""
  for {set y 0} {$y<$height} {incr y} {
    set row ""
    for {set x 0} {$x<$width} {incr x} {
      lappend row 0
    }
    lappend data $row
  }
  return $data
}

proc newfont {width height baseline} {
  global chardata fontinfo origdata currchar currfile holddata
  global WIDTH HEIGHT FLEFT FTOP FRIGHT FBOTTOM

  #resize clipboard
  for {set encod 0} {$encod<32} {incr encod} {
    if ([info exists holddata($encod)]) {
      #do the resize so data remains same relative to baseline
      set holddata($encod) [resizedata $holddata($encod) \
	  0 [expr $width-$WIDTH] \
	  [expr ($height+$baseline)-($HEIGHT+$fontinfo(yorigin))] \
	  [expr $fontinfo(yorigin)-$baseline] ]
    }
  }
  resetall
  set WIDTH $width
  set HEIGHT $height
  set fontinfo(width) $width
  set fontinfo(height) $height
  set fontinfo(yorigin) $baseline
  set fontinfo(xorigin) 0
  set fontinfo(fontname) UNTITLED
  set fontinfo(pointsize) [expr int($WIDTH*1.5)]
  set fontinfo(xres) 72
  set fontinfo(yres) 72
  set FLEFT 15
  set FTOP 15
  set FRIGHT [expr $FLEFT+32*$WIDTH]
  set FBOTTOM [expr $FTOP+8*$HEIGHT]
  set currfile ""
  .savedialog.e delete 0 end

  set currchar 65
  set chardata(work) [blankchar $WIDTH $HEIGHT]
  set chardata(dwidth,work) $WIDTH
  makegrid $WIDTH $HEIGHT $fontinfo(xorigin) $fontinfo(yorigin)
  showfont
  setgrid chardata work
  wm withdraw .newdialog
  grab release .newdialog
}

proc loadbdffont {fh} {
  global WIDTH HEIGHT chardata fontinfo origdata holddata
  global FLEFT FTOP FRIGHT FBOTTOM
  global hex2bin
  set saveprops 1
  set inproperties 0

  set oldbase $fontinfo(yorigin)
  set oldwidth $WIDTH
  set oldheight $HEIGHT
  if [gets $fh line]<=-1 {
    .messdialog.m config -text "Couldn't read from file\n (is it empty?)"
    wm deiconify .messdialog
    return 0
  }
  if [string first "STARTFONT " $line]<0 {
    .messdialog.m config -text "This is not a BDF file"
    wm deiconify .messdialog
    return 0
  }
  resetall
  while {[gets $fh line]>-1} {
    if [regexp {^[0-9a-fA-F][0-9a-fA-F]+$} $line] {
      set row ""
      if !$ready { puts "unexpected" }
      scan $line %x decimal
      #pad left edge of char
      set max [expr $cx-$fontinfo(xorigin)]
      for {set i 0} {$i<$max} {incr i} {
	lappend row 0
      }
      #fill in data
      incr max $cwd
      foreach hex [split $line ""] {
	foreach digit $hex2bin($hex) {
	  lappend row $digit
	  if ([incr i]>=$max) break
	}
        if ($i>=$max) break
      }
      #pad right edge of char
      for {} {$i<$WIDTH} {incr i} {
	lappend row 0
      }
      lappend chardata($encod) $row
      incr rownum
    } elseif [string first "COMMENT " $line]==0 {
      if [info exists fontinfo(COMMENT)] {
	set fontinfo(COMMENT) $fontinfo(COMMENT)[string range $line [expr [string first " " $line]+1] end]\n
      } else {
	set fontinfo(COMMENT) [string range $line [expr [string first " " $line]+1] end]\n
      }
    } elseif [string first "COPYRIGHT " $line]==0 {
      set chardata(COPYRIGHT) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(copyright) [string trim $chardata(COPYRIGHT) {"}]
    } elseif [string first "FOUNDRY " $line]==0 {
      set chardata(FOUNDRY) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(foundry) [string trim $chardata(FOUNDRY) {"}]
    } elseif [string first "FAMILY_NAME " $line]==0 {
      set chardata(FAMILY_NAME) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(family) [string trim $chardata(FAMILY_NAME) {"}]
    } elseif [string first "WEIGHT_NAME " $line]==0 {
      set chardata(WEIGHT_NAME) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(weight) [string trim $chardata(WEIGHT_NAME) {"}]
    } elseif [string first "SLANT " $line]==0 {
      set chardata(SLANT) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(slant) [string trim $chardata(SLANT) {"}]
    } elseif [string first "SETWIDTH_NAME " $line]==0 {
      set chardata(SETWIDTH_NAME) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(widthname) [string trim $chardata(SETWIDTH_NAME) {"}]
    } elseif [string first "FONT " $line]==0 {
      if (!$inproperties) {
	set chardata(FONT) [string range $line [expr [string first " " $line]+1] end]
	set fontinfo(fontname) $chardata(FONT)
      }
    } elseif [string first "FONTBOUNDINGBOX " $line]==0 {
      #width height -xorigin -yorigin
      set fontinfo(width) [lindex $line 1]
      set fontinfo(height) [lindex $line 2]
      set fontinfo(xorigin) [lindex $line 3]
      set fontinfo(yorigin) [lindex $line 4]
      set chardata(FONTBOUNDINGBOX) [string range $line [expr [string first " " $line]+1] end]
      set WIDTH [lindex $line 1]
      set HEIGHT [lindex $line 2]
      #resize clipboard
      for {set encod 0} {$encod<32} {incr encod} {
	if ([info exists holddata($encod)]) {
	  #do the resize so data remains same relative to baseline
	  set holddata($encod) [resizedata $holddata($encod) \
	    0 [expr $WIDTH-$oldwidth] \
	    [expr ($HEIGHT+$fontinfo(yorigin))-($oldheight+$oldbase)] \
	    [expr $oldbase-$fontinfo(yorigin)]]
	}
      }
    } elseif [string first "SIZE " $line]==0 {
      set chardata(SIZE) [string range $line [expr [string first " " $line]+1] end]
      set fontinfo(pointsize) [lindex $line 1]
      set fontinfo(xres) [lindex $line 2]
      set fontinfo(yres) [lindex $line 3]
    } elseif [string first "CHARS " $line]==0 {
      set total [string range $line [expr [string first " " $line]+1] end]
      set chardata(CHARS) $total
      set count 0
      wm deiconify .status
      . config -cursor watch
      if [string length [grab current]]==0 { grab .status }
      showstatus $count $total "Loading font..."
    } elseif [string first "STARTPROPERTIES " $line]==0 {
      set inproperties 1
    } elseif [string first "ENDPROPERTIES" $line]==0 {
      set inproperties 0
    } elseif [string first "STARTCHAR " $line]==0 {
      set char [string range $line [expr [string first " " $line]+1] end]
    } elseif [string first "ENCODING " $line]==0 {
      set encod [string range $line [expr [string first " " $line]+1] end]
      set chardata(name,$encod) $char
      set origdata(name,$encod) $char
    } elseif [string first "DWIDTH " $line]==0 {
      set chardata(dwidth,$encod) [lindex $line 1]
      set origdata(dwidth,$encod) [lindex $line 1]
    } elseif [string first "BBX " $line]==0 {
      #width height startx starty
      set cwd [lindex $line 1]
      set cht [lindex $line 2]
      set cx [lindex $line 3]
      set cy [lindex $line 4]
      set chardata(width,$encod) $cwd
      set chardata(height,$encod) $cht
      set chardata(xorigin,$encod) $cx
      set chardata(yorigin,$encod) $cy
    } elseif [string compare "ENDPROPERTIES" $line]==0 {
      set saveprops 0
    } elseif [string compare "ENDCHAR" $line]==0 {
      set ready 0
      for {} {$rownum<$HEIGHT} {incr rownum} {
	set row ""
	for {set i 0} {$i<$WIDTH} {incr i} {
	  lappend row 0
	}
        lappend chardata($encod) $row
      }
      set origdata($encod) $chardata($encod)
      incr count
      showstatus $count $total
    } elseif [string compare "BITMAP" $line]==0 {
      set ready 1
      set chardata($encod) ""
      for {set rownum 0} {$rownum<[expr $HEIGHT-$cht-($cy-$fontinfo(yorigin))]} {incr rownum} {
	set row ""
	for {set i 0} {$i<$WIDTH} {incr i} {
	  lappend row 0
	}
        lappend chardata($encod) $row
      }
    } elseif [string compare "COMMENT" $line]==0 {
      if [info exists fontinfo(COMMENT)] {
	set fontinfo(COMMENT) "$fontinfo(COMMENT)\n"
      } else {
	set fontinfo(COMMENT) "\n"
      }
    } elseif [string compare "ENDFONT" $line]==0 {
      grab release .status
      . config -cursor ""
      after 300 "wm withdraw .status"
    } else {
      if [string first " " $line]==-1 {
	puts $line
      } elseif $saveprops {
	set firstword [string range $line 0 [expr [string first " " $line]-1]]
	set rest [string range $line [expr [string first " " $line]+1] end]
	set fontinfo($firstword) $rest
      }
    }
  }
  set FLEFT 15
  set FTOP 15
  set FRIGHT [expr $FLEFT+32*$WIDTH]
  set FBOTTOM [expr $FTOP+8*$HEIGHT]
  return 1
}

proc savebdffont {fh} {
  global fontinfo chardata default
  #skip empty characters ??
  #skip unset characters
  #reduce saved data to appropriate bounding box

  . config -cursor watch
  if (![info exists fontinfo(pointsize)]) {
    set fontinfo(pointsize) [expr int($fontinfo(width)*1.5)]
  }
  set numchars 0
  for {set encod 0} {$encod<256} {incr encod} {
    if (![info exists chardata($encod)]) continue
    incr numchars
  }

  puts $fh "STARTFONT 2.1"
  if (![info exists fontinfo(COMMENT)]) {
    set fontinfo(COMMENT) $default(COMMENT)
  }
  foreach line [lreplace [split $fontinfo(COMMENT) \n] end end] {
    if [string length $line]==0 {
      puts $fh COMMENT
    } else {
      puts $fh "COMMENT $line"
    }
  }
  #CONTENTVERSION
  puts $fh "FONT $fontinfo(fontname)"
  puts $fh "SIZE $fontinfo(pointsize) $fontinfo(xres) $fontinfo(yres)"
  puts $fh "FONTBOUNDINGBOX $fontinfo(width) $fontinfo(height) $fontinfo(xorigin) $fontinfo(yorigin)"
  puts $fh "STARTPROPERTIES 11"
  #FONTNAME_REGISTRY
  puts $fh "FOUNDRY \"$fontinfo(foundry)\""
  puts $fh "FAMILY_NAME \"$fontinfo(family)\""
  puts $fh "WEIGHT_NAME \"$fontinfo(weight)\""
  puts $fh "SLANT \"$fontinfo(slant)\""
  puts $fh "SETWIDTH_NAME \"$fontinfo(widthname)\""
  #ADD_STYLE_NAME
  #PIXEL_SIZE
  #POINT_SIZE
  #RESOLUTION_X
  #RESOLUTION_Y
  puts $fh {SPACING "c"}
  #AVERAGE_WIDTH ??
  puts $fh {CHARSET_REGISTRY "ISO-8859"}
  puts $fh {CHARSET_ENCODING "1"}
  #COPYRIGHT 
  puts $fh "COPYRIGHT \"$fontinfo(copyright)\""
  #FONT (same as non-property font line, but with quotes)
  #WEIGHT num?
  #RESOLUTION ?
  #X_HEIGHT ?
  #QUAD_WIDTH ?
  #DEFAULT_CHAR ? (32)