bdfedit

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

}

proc renamechar {} {
  global currchar chardata
  .chardialog.e delete 0 end
  if [info exists chardata(name,$currchar)] {
    .chardialog.e insert 0 $chardata(name,$currchar)
  }
  wm deiconify .chardialog
  grab .chardialog
}

proc setcharname {name} {
  global currchar chardata
  set chardata(name,$currchar) $name
  wm withdraw .chardialog
  grab release .chardialog
  set txt [format "%d (%c) %s" $currchar $currchar $name]
  .c itemconfig charlabel -text $txt
}

proc drawresizer {} {
  global currchar chardata WIDTH HEIGHT fontinfo resize
  set c .resizedialog.c
  set w [winfo width .resizedialog.c]
  set h [winfo height .resizedialog.c]
  set gsz $resize(gsz)
  set left $resize(gleft)
  set top $resize(gtop)


  $c delete all
  for {set i 0} {$i<$w} {incr i $gsz} { $c create line $i 0 $i $h -fill grey}
  for {set i 0} {$i<$h} {incr i $gsz} { $c create line 0 $i $w $i -fill grey}
  $c create rectangle $left $top [expr $left+$WIDTH*$gsz] [expr $top+$HEIGHT*$gsz]
  $c create line $left [expr $top+($HEIGHT+$fontinfo(yorigin))*$gsz] [expr $left+$WIDTH*$gsz] [expr $top+($HEIGHT+$fontinfo(yorigin))*$gsz]
  $c create line [expr $left-$fontinfo(xorigin)*$gsz] $top [expr $left-$fontinfo(xorigin)*$gsz] [expr $top+$HEIGHT*$gsz]

  set resize(left) 0
  set resize(right) $WIDTH
  set resize(top) 0
  set resize(bottom) $HEIGHT
  set resize(yorigin) [expr $HEIGHT+$fontinfo(yorigin)]
  set resize(xorigin) [expr 0-$fontinfo(xorigin)]

  $c create line 0 0 0 0 -fill skyblue -width 3 -tags yorigin
  $c create line 0 0 0 0 -fill skyblue -width 3 -tags xorigin
  $c create line 0 0 0 0 -fill green -width 3 -tags left
  $c create line 0 0 0 0 -fill green -width 3 -tags right
  $c create line 0 0 0 0 -fill green -width 3 -tags top
  $c create line 0 0 0 0 -fill green -width 3 -tags bottom

  fix_resizers

  $c bind left      <1> "pick_resizers left      %x %y"
  $c bind right     <1> "pick_resizers right     %x %y"
  $c bind top       <1> "pick_resizers top       %x %y"
  $c bind bottom    <1> "pick_resizers bottom    %x %y"
  $c bind yorigin   <1> "pick_resizers yorigin   %x %y"
  $c bind xorigin   <1> "pick_resizers xorigin   %x %y"
  $c bind left      <B1-Motion> "change_resizers left      %x %y"
  $c bind right     <B1-Motion> "change_resizers right     %x %y"
  $c bind top       <B1-Motion> "change_resizers top       %x %y"
  $c bind bottom    <B1-Motion> "change_resizers bottom    %x %y"
  $c bind yorigin   <B1-Motion> "change_resizers yorigin   %x %y"
  $c bind xorigin   <B1-Motion> "change_resizers xorigin   %x %y"

}

proc pick_resizers {which x y} {
  global resize
  set nx [expr ($x-$resize(gleft)+($resize(gsz)/2))/$resize(gsz)]
  set ny [expr ($y-$resize(gtop)+($resize(gsz)/2))/$resize(gsz)]
  set resize(which) $which
  set resize(lastx) $nx
  set resize(lasty) $ny
}

proc change_resizers {which x y} {
  global resize
  set nx [expr ($x-$resize(gleft)+($resize(gsz)/2))/$resize(gsz)]
  set ny [expr ($y-$resize(gtop)+($resize(gsz)/2))/$resize(gsz)]
  if ($nx==$resize(lastx)&&$ny==$resize(lasty)) return
  set resize(lastx) $nx
  set resize(lasty) $ny
  switch -- $which {
    left {
      if ($nx>=$resize(right)) { set nx [expr $resize(right)-1] }
      set resize(left) $nx
    }
    right {
      if ($nx<=$resize(left)) { set nx [expr $resize(left)+1] }
      set resize(right) $nx
    }
    top {
      if ($ny>=$resize(bottom)) { set ny [expr $resize(bottom)-1] }
      set resize(top) $ny
    }
    bottom {
      if ($ny<=$resize(top)) { set ny [expr $resize(top)+1] }
      set resize(bottom) $ny
    }
    yorigin {
      if ($ny<$resize(top)) { set ny [expr $resize(top)] }
      if ($ny>$resize(bottom)) { set ny [expr $resize(bottom)] }
      set resize(yorigin) $ny
    }
    xorigin {
      if ($nx<$resize(left)) { set nx [expr $resize(left)] }
      if ($nx>$resize(right)) { set nx [expr $resize(right)] }
      set resize(xorigin) $nx
    }
  }
  fix_resizers
}

proc fix_resizers {} {
  global resize

  set lx [expr $resize(left)*$resize(gsz)+$resize(gleft)]
  set rx [expr $resize(right)*$resize(gsz)+$resize(gleft)]
  set ty [expr $resize(top)*$resize(gsz)+$resize(gtop)]
  set by [expr $resize(bottom)*$resize(gsz)+$resize(gtop)]
  set yoy [expr $resize(yorigin)*$resize(gsz)+$resize(gtop)]
  set xox [expr $resize(xorigin)*$resize(gsz)+$resize(gleft)]

  set c .resizedialog.c
  $c coords left   $lx $ty $lx $by
  $c coords right  $rx $ty $rx $by
  $c coords top    $lx $ty $rx $ty
  $c coords bottom $lx $by $rx $by
  $c coords yorigin [expr $lx-$resize(gsz)] $yoy [expr $rx+$resize(gsz)] $yoy
  $c coords xorigin $xox [expr $ty-$resize(gsz)] $xox [expr $by+$resize(gsz)]

  set w [expr $resize(right)-$resize(left)]
  set h [expr $resize(bottom)-$resize(top)]
  set base [expr $resize(yorigin)-$resize(bottom)]
  .resizedialog.l config -text "Size: ${w}x${h}  Baseline: $base"
}

proc doresize {} {
  global fontinfo chardata origdata holddata resize
  global FLEFT FRIGHT FTOP FBOTTOM WIDTH HEIGHT
  set dleft   [expr 0-$resize(left)]
  set dright  [expr $resize(right)-$WIDTH]
  set dtop    [expr 0-$resize(top)]
  set dbottom [expr $resize(bottom)-$HEIGHT]
  set newyorg [expr $resize(yorigin)-$resize(bottom)]
  set newxorg [expr $resize(left)-$resize(xorigin)]

  set newwidth [expr $WIDTH+($dleft)+($dright)]
  set newheight [expr $HEIGHT+($dtop)+($dbottom)]
  for {set encod 0} {$encod<256} {incr encod} {
    if ([info exists chardata($encod)]) {
      set chardata($encod) \
	  [resizedata $chardata($encod) $dleft $dright $dtop $dbottom]
    }
    if ([info exists origdata($encod)]) {
      set origdata($encod) \
	  [resizedata $origdata($encod) $dleft $dright $dtop $dbottom]
    }
  }
  for {set encod 0} {$encod<32} {incr encod} {
    if ([info exists holddata($encod)]) {
      set holddata($encod) \
	  [resizedata $holddata($encod) $dleft $dright $dtop $dbottom]
    }
  }
  set chardata(work) [resizedata $chardata(work) $dleft $dright $dtop $dbottom]
  set WIDTH $newwidth
  set HEIGHT $newheight
  set FLEFT 15
  set FTOP 15
  set FRIGHT [expr $FLEFT+32*$WIDTH]
  set FBOTTOM [expr $FTOP+8*$HEIGHT]
  set fontinfo(width) $newwidth
  set fontinfo(height) $newheight
  set fontinfo(yorigin) $newyorg
  set fontinfo(xorigin) $newxorg
  wm withdraw .resizedialog
  grab release .resizedialog
  .c delete all
  .fc delete all
  makegrid $WIDTH $HEIGHT $fontinfo(xorigin) $fontinfo(yorigin)
  showfont
  setgrid chardata work
}

#all numbers are positive for row/column of data being added
proc resizedata {data dleft dright dtop dbottom} {
  set orig_width [llength [lindex $data 0]]
  set orig_height [llength $data]
  set newwidth [expr $orig_width+($dleft)+($dright)]
  set newheight [expr $orig_height+($dtop)+($dbottom)]
  set blankrow ""
  for {set i 0} {$i<$newwidth} {incr i} { lappend blankrow 0 }
  set newdata ""

  if ($dtop>0) {
    for {set i 0} {$i<$dtop} {incr i} {
      lappend newdata $blankrow
    }
    set startrow 0
  } else {
    set startrow [expr 0-$dtop]
  }
  if ($dbottom<0) {
    set endrow [expr $orig_height+$dbottom]
  } else {
    set endrow $orig_height
  }

  for {set i $startrow} {$i<$endrow} {incr i} {
    set row [lindex $data $i]
    #do the right side first, because changes are based on width of rowdata
    #(if left changed first, it would screw up changes on right)
    if ($dright>0) {
      for {set j 0} {$j<$dright} {incr j} { lappend row 0 }
    } elseif ($dright<0) {
      set row [lreplace $row [expr $orig_width+$dright] end]
    }
    if ($dleft>0) {
      for {set j 0} {$j<$dleft} {incr j} { set row [linsert $row 0 0] }
    } elseif ($dleft<0) {
      set row [lreplace $row 0 [expr 0-$dleft-1]]
    }
    lappend newdata $row
  }

  if ($dbottom>0) {
    for {set i 0} {$i<$dbottom} {incr i} {
      lappend newdata $blankrow
    }
  }
  return $newdata
}

proc doload {filename} {
  global currchar WIDTH HEIGHT chardata fontinfo currfile
  if [string first @ $filename]>=0 {
    set fontname [string range $filename 0 [expr [string first @ $filename]-1]]
    set server [string range $filename [expr [string first @ $filename]+1] end]
    if [string length $server]==0 {
      set server "localhost:7100"
    }
    if [string first : $server]<0 {
      set server "$server:7100"
    }
    if [catch "open \"|fstobdf -server $server -fn $fontname\" r" fh] {
      .messdialog.m config -text "Couldn't open $filename: $fh"
      wm deiconify .messdialog
      return
    }
  } else {
    if [catch "open $filename r" fh] {
      .messdialog.m config -text "Couldn't open $filename: $fh"
      wm deiconify .messdialog
      return
    }
  }
  wm withdraw .loaddialog
  grab release .loaddialog
  if ![loadbdffont $fh] {
    close $fh
    return
  }
  if [info exists fontname] {
    set currfile "$fontname.bdf"
  } else {
    set currfile $filename
  }
  .savedialog.e delete 0 end
  .savedialog.e insert 0 $filename
  catch "close $fh" err
  set currchar 65
  if [info exists chardata(65)] {
    set chardata(work) $chardata(65)
    set chardata(dwidth,work) $chardata(dwidth,65)
  } else {
    set chardata(work) [blankchar $WIDTH $HEIGHT]
    set chardata(dwidth,work) $WIDTH
  }
  makegrid $WIDTH $HEIGHT $fontinfo(xorigin) $fontinfo(yorigin)
  showfont
  setgrid chardata work
}

proc dosave {filename} {
  global currfile
  if [catch "open $filename w" fh] {
    .messdialog.m config -text "Couldn't open $filename: $fh"
    wm deiconify .messdialog
    return
  }
  showstatus 0 100 "Saving $filename..."
  wm deiconify .status
  . config -cursor watch
  if [string length [grab current]]==0 { grab .status }
  savebdffont $fh
  if [catch "close $fh" err] {
    .messdialog.m config -text "Couldn't CLOSE $filename: $fh"
    wm deiconify .messdialog
    return
  }
  . config -cursor ""
  wm withdraw .savedialog
  wm withdraw .status
  grab release [grab current]
  set currfile $filename
}

proc clearwork {} {
  global chardata WIDTH HEIGHT fontinfo
  set chardata(work) [blankchar $WIDTH $HEIGHT]
  set chardata(dwidth,work) [expr $WIDTH+$fontinfo(xorigin)]
  #don't change the char name when clearing
  #set chardata(name,work) ""
  setgrid chardata work
}

proc applywork {} {
  global WIDTH HEIGHT chardata currchar
  if [info exists chardata($currchar)] {
    if [checkhold $chardata($currchar) $chardata(work)] {
      hold $currchar
    }
  }
  set chardata($currchar) $chardata(work)
  showfontchar $currchar
  set chardata(dwidth,$currchar) $chardata(dwidth,work)
}

proc resetwork {} {
  global WIDTH HEIGHT chardata currchar
  if [info exists chardata($currchar)] {
    set chardata(work) $chardata($currchar)
  } else {
    set chardata(work) [blankchar $WIDTH $HEIGHT]
  }
  if [info exists chardata(dwidth,$currchar)] {
    set chardata(dwidth,work) $chardata(dwidth,$currchar)
  } else {
    set chardata(dwidth,work) $WIDTH
  }
  if [info exists chardata(name,$currchar)] {
    set chardata(name,work) $chardata(name,$currchar)
  } else {
    set chardata(name,work) ""
  }
  setgrid chardata work
}

proc origwork {} {
  global chardata WIDTH HEIGHT origdata currchar
  if [info exists origdata($currchar)] {
    set chardata(work) $origdata($currchar)
  } else {
    set chardata(work) [blankchar $WIDTH $HEIGHT]
  }
  if [info exists origdata(dwidth,$currchar)] {
    set chardata(dwidth,work) $origdata(dwidth,$currchar)
  } else {
    set chardata(dwidth,work) $WIDTH
  }
  if [info exists origdata(name,$currchar)] {
    set chardata(name,work) $origdata(name,$currchar)
  } else {
    set chardata(name,work) ""
  }
  setgrid chardata work
}

proc checkhold {savedata compdata} {
  global WIDTH HEIGHT
  set nonblank 0
  set diff 0
  for {set i 0} {$i<$HEIGHT} {incr i} {
    set saverow [lindex $savedata $i]
    set comprow [lindex $compdata $i]
    for {set j 0} {$j<$WIDTH} {incr j} {
      set savebit [lindex $saverow $j]
      set compbit [lindex $comprow $j]
      if $savebit { incr nonblank }
      if $savebit!=$compbit { incr diff }
    }
  }
  return [expr $diff && $nonblank]
}

proc hold {key} {
  global chardata holddata holdserial HLEFT HTOP WIDTH HEIGHT
  set data $chardata($key)
  set dwidth $chardata(dwidth,$key)
  #find a free spot
  set spot -1
  set oldest -1
  set oldserial 999999999
  for {set i 0} {$i<32} {incr i} {
    if ![info exists holddata($i)] {
      set spot $i
      break
    }
    if $holdserial($i)<$oldserial {
      set oldserial $holdserial($i)
      set oldest $i
    }
  }
  #if no spot, remove oldest to make space
  if $spot==-1 {
    set spot $oldest
  }
  #put it there
  .fc delete HOLD$spot
  set holddata($spot) $data
  set holddata(dwidth,$spot) $dwidth
  set holdserial($spot) [incr holdserial(last)]
  showchardata .fc [expr $HLEFT+$WIDTH*$spot] $HTOP $data HOLD$spot
}

proc showchardata {canv x y data tag} {
  set ox $x
  $canv delete $tag
  foreach row $data {
    foreach bit $row {
      if $bit {
	$canv create rectangle $x $y $x $y -fill black -outline "" -tags $tag
      }
      incr x
    }
    set x $ox
    incr y
  }
}

proc showfontchar {num} {
  global chardata WIDTH HEIGHT FTOP FLEFT FRIGHT FBOTTOM