bdfedit

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

  set x [expr $FLEFT+($num%32)*$WIDTH]
  set y [expr $FTOP+(int($num/32))*$HEIGHT]
  if [info exists chardata($num)] {
    showchardata .fc $x $y $chardata($num) "NUM$num"
  } else {
    .fc delete NUM$num
    .fc create rectangle $x $y [expr $x+$WIDTH-1] [expr $y+$HEIGHT-1] \
	    -fill skyblue -outline "" -tags NUM$num
  }
}

proc showholdchar {num} {
  global holddata WIDTH HEIGHT HTOP HLEFT
  set x [expr $HLEFT+$num*$WIDTH]
  set y $HTOP
  if [info exists holddata($num)] {
    showchardata .fc $x $y $holddata($num) "HOLD$num"
  } else {
    .fc delete HOLD$num
    .fc create rectangle $x $y [expr $x+$WIDTH-1] [expr $y+$HEIGHT-1] \
	    -fill pink -outline "" -tags HOLD$num
  }
}

proc showfont {} {
  global currchar chardata fontinfo WIDTH HEIGHT FTOP FLEFT FRIGHT FBOTTOM
  .fc delete whichchar
  .fc delete draghilite
  for {set i 0} {$i<256} {incr i} {
    showfontchar $i
    update
  }
  for {set i 0} {$i<32} {incr i} {
    showholdchar $i
    update
  }
  set x1 [expr ($currchar%32)*$WIDTH-3+$FLEFT]
  set y1 [expr ($currchar/32)*$HEIGHT-3+$FTOP]
  .fc create rectangle $x1 $y1 [expr $x1+$WIDTH+6] [expr $y1+$HEIGHT+6] -tags whichchar -outline red
  .fc create rectangle -5 -5 -5 -5 -tags draghilite -outline green
}

set WIDTH 12
set HEIGHT 24

proc setchar {charnum} {
  global WIDTH HEIGHT FBOTTOM FLEFT FTOP FRIGHT
  global chardata currchar

  if [info exists chardata($currchar)] {
    if [checkhold $chardata(work) $chardata($currchar)] {
      hold work
    }
  }

  set currchar $charnum
  if ![info exists chardata($currchar)] {
    set chardata(work) [blankchar $WIDTH $HEIGHT]
  } else {
    set chardata(work) $chardata($currchar)
  }
  if [info exists chardata(dwidth,$currchar)] {
    #set chardata(dwidth,$currchar) $chardata(dwidth,$currchar)
    set chardata(dwidth,work) $chardata(dwidth,$currchar)
  } else {
    #set chardata(dwidth,$currchar) $WIDTH
    set chardata(dwidth,work) $WIDTH
  }
  setgrid chardata work
  set x1 [expr ($currchar%32)*$WIDTH-3+$FLEFT]
  set y1 [expr ($currchar/32)*$HEIGHT-3+$FTOP]
  .fc coords whichchar $x1 $y1 [expr $x1+$WIDTH+6] [expr $y1+$HEIGHT+6]
  .fc raise whichchar
}

proc selectleft {} {
  global currchar
  if ($currchar) {
    setchar [expr $currchar-1]
  }
}

proc selectright {} {
  global currchar
  if ($currchar<255) {
    setchar [expr $currchar+1]
  }
}

proc selectup {} {
  global currchar
  if ($currchar>=32) {
    setchar [expr $currchar-32]
  }
}

proc selectdown {} {
  global currchar
  if ($currchar<=223) {
    setchar [expr $currchar+32]
  }
}

proc nukechar {x y} {
  global WIDTH HEIGHT FBOTTOM FLEFT FTOP FRIGHT HLEFT HTOP
  global chardata currchar holddata
  set fx [expr ($x-$FLEFT)/($WIDTH)]
  set fy [expr ($y-$FTOP)/($HEIGHT)]
  set hx [expr ($x-$HLEFT)/($WIDTH)]
  set hy [expr ($y-$HTOP)/($HEIGHT)]
  if {$fx>=0 && $fx<32 && $fy>=0 && $fy<8} {
    set num [expr $fx+$fy*32]
    if [info exists chardata($num)] {
      hold $num
      unset chardata($num)
      unset chardata(dwidth,$num)
      .fc delete NUM$num
      set x [expr $fx*$WIDTH+$FLEFT]
      set y [expr $fy*$HEIGHT+$FTOP]
      .fc create rectangle $x $y [expr $x+$WIDTH-1] [expr $y+$HEIGHT-1] \
	      -fill skyblue -outline "" -tags NUM$num
    }
  } elseif {$hx>=0 && $hx<32 && $hy==0} {
    if [info exists holddata($hx)] {
      unset holddata($hx)
      unset holddata(dwidth,$hx)
      .fc delete HOLD$hx
      set x [expr $hx*$WIDTH+$HLEFT]
      set y [expr $hy*$HEIGHT+$HTOP]
      .fc create rectangle $x $y [expr $x+$WIDTH-1] [expr $y+$HEIGHT-1] \
	      -fill pink -outline "" -tags HOLD$hx
    }
  }
}

proc pickchar {x y} {
  global WIDTH HEIGHT FBOTTOM FLEFT FTOP FRIGHT HLEFT HTOP
  global chardata currchar holddata
  global pickchar pickstate
  set fx [expr ($x-$FLEFT)/($WIDTH)]
  set fy [expr ($y-$FTOP)/($HEIGHT)]
  set hx [expr ($x-$HLEFT)/($WIDTH)]
  set hy [expr ($y-$HTOP)/($HEIGHT)]
  set pickchar -1
  if {$fx>=0 && $fx<32 && $fy>=0 && $fy<8} {
    if [string first after $pickstate]==0 {
      after cancel $pickstate
    }
    set pickstate nogrid
    set pickchar [expr $fx+$fy*32]
    if [info exists chardata($pickchar)] {
      set chardata(pick) $chardata($pickchar)
      set chardata(dwidth,pick) $chardata(dwidth,$pickchar)
      make_drag_cursor $WIDTH $HEIGHT [expr $WIDTH/2] [expr $HEIGHT/2] $chardata(pick)
      . config -cursor "@/tmp/drag_cursor.bm /tmp/drag_cursor.bm black white"
      bind .c <Enter> "checkdrop %x %y"
      set pickstate [after 1000 "set pickstate gridok"]
    }
  } elseif {$hx>=0 && $hx<32 && $hy==0} {
    set pickchar hold
    set pickstate gridok
    if [info exists holddata($hx)] {
      set chardata(pick) $holddata($hx)
      set chardata(dwidth,pick) $holddata(dwidth,$hx)
      make_drag_cursor $WIDTH $HEIGHT [expr $WIDTH/2] [expr $HEIGHT/2] $chardata(pick)
      . config -cursor "@/tmp/drag_cursor.bm /tmp/drag_cursor.bm black white"
      bind .c <Enter> "checkdrop %x %y"
    }
  }
}

proc dragchar {x y} {
  global WIDTH HEIGHT FBOTTOM FLEFT FTOP FRIGHT HLEFT HTOP
  global pickchar pickstate oldcurrent
  set fx [expr ($x-$FLEFT)/($WIDTH)]
  set fy [expr ($y-$FTOP)/($HEIGHT)]
  set hx [expr ($x-$HLEFT)/($WIDTH)]
  set hy [expr ($y-$HTOP)/($HEIGHT)]
  if {$fx>=0 && $fx<32 && $fy>=0 && $fy<8} {
    if [string compare $pickstate gridok]==0 {
      .fc coords draghilite [expr $FLEFT+$fx*$WIDTH-2] [expr $FTOP+$fy*$HEIGHT-2] [expr $FLEFT+($fx+1)*$WIDTH+2] [expr $FTOP+($fy+1)*$HEIGHT+2]
    }
  } elseif {$hx>=0 && $hx<32 && $hy==0} {
    if [string compare $pickchar hold]!=0 {
      .fc coords draghilite [expr $HLEFT-2] [expr $HTOP-2] [expr $HLEFT+32*$WIDTH+2] [expr $HTOP+$HEIGHT+2]
    }
  } else {
    .fc coords draghilite -5 -5 -5 -5
  }
}

proc enddragchar {x y} {
  global WIDTH HEIGHT FBOTTOM FLEFT FTOP FRIGHT HLEFT HTOP
  global chardata currchar
  global pickchar pickstate

  after 100 {bind .c <Enter> ""}
  . config -cursor {}
  .fc coords draghilite -5 -5 -5 -5
  update
  set fx [expr ($x-$FLEFT)/($WIDTH)]
  set fy [expr ($y-$FTOP)/($HEIGHT)]
  set hx [expr ($x-$HLEFT)/($WIDTH)]
  set hy [expr ($y-$HTOP)/($HEIGHT)]
  set newchar [expr $fx+$fy*32]
  if [string compare $pickchar $newchar]==0 {
    setchar $pickchar
  } elseif {$fx>=0 && $fx<32 && $fy>=0 && $fy<8} {
    if [string compare $pickstate gridok]==0 {
      set dropchar [expr $fx+$fy*32]
      if [info exists chardata($dropchar)] {
	if [checkhold $chardata($dropchar) $chardata(pick)] {
	  hold $dropchar
	}
      }
      set chardata($dropchar) $chardata(pick)
      set chardata(dwidth,$dropchar) $chardata(dwidth,pick)
      showfontchar $dropchar
      if $dropchar==$currchar {
	setgrid chardata pick
	set chardata(work) $chardata(pick)
	set chardata(dwidth,work) $chardata(dwidth,pick)
      }
    }
  } elseif {$hx>=0 && $hx<32 && $hy==0} {
    if [string compare $pickchar hold]!=0 {
      hold pick
    }
  }
}

proc checkdrop {x y} {
  global GLEFT GTOP WIDTH HEIGHT GBOX GMARGIN chardata
  set left [expr $GLEFT-3]
  set right [expr $GLEFT+$WIDTH+3]
  set top [expr $GTOP-$HEIGHT-15-3]
  set bottom [expr $GTOP-15+3]
  set gright [expr $GLEFT+$WIDTH*($GBOX+$GMARGIN)]
  set gbottom [expr $GTOP+$HEIGHT*($GBOX+$GMARGIN)]
  if {$x>= $left && $x <= $right && $y >= $top && $y <= $bottom} {
    setgrid chardata pick
    set chardata(work) $chardata(pick)
    set chardata(dwidth,work) $chardata(dwidth,pick)
  } elseif {$x>= $GLEFT && $x <= $gright && $y >= $GTOP && $y <= $gbottom} {
    setgrid chardata pick
    set chardata(work) $chardata(pick)
    set chardata(dwidth,work) $chardata(dwidth,pick)
  }
}

proc click {x y action} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT
  global ogx ogy
  if [lsearch -exact [.c gettags [.c find withtag current]] dwidth]>=0 {
    set ogx dwidth
    return
  }
  set gx [expr ($x-$GLEFT)/($GBOX+$GMARGIN)]
  set gy [expr ($y-$GTOP)/($GBOX+$GMARGIN)]
  set gxmarg [expr ($x-$GLEFT)%($GBOX+$GMARGIN)]
  set gymarg [expr ($y-$GTOP)%($GBOX+$GMARGIN)]
  set faredge [expr $GBOX+$GMARGIN-1]
  if ($gxmarg==0||$gxmarg==$faredge||$gymarg==0||$gymarg==$faredge) {
    set ogx -1
    set ogy -1
    return
  }
  if {$gx>=0 && $gx<$WIDTH && $gy>=0 && $gy<$HEIGHT} {
    $action $gx $gy
  }
  set ogx $gx
  set ogy $gy
}

proc bmotion {x y action} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT
  global ogx ogy
  if [string compare $ogx dwidth]==0 {
    adjustdwidth $x $y
    return
  }
  set gx [expr ($x-$GLEFT)/($GBOX+$GMARGIN)]
  set gy [expr ($y-$GTOP)/($GBOX+$GMARGIN)]
  set gxmarg [expr ($x-$GLEFT)%($GBOX+$GMARGIN)]
  set gymarg [expr ($y-$GTOP)%($GBOX+$GMARGIN)]
  if ($gxmarg==0||$gxmarg==$WIDTH||$gymarg==0||$gymarg==$WIDTH) {
    return
  }
  if {$gx>=0 && $gx<$WIDTH && $gy>=0 && $gy<$HEIGHT} {
    if {$gx!=$ogx || $gy!=$ogy} {
      $action $gx $gy
      set ogx $gx
      set ogy $gy
    }
  }
}

proc makegrid {width height xorg yorg} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT FTOP FBOTTOM FLEFT FRIGHT GPAD
  global HLEFT HTOP
  set GTOP [expr $GPAD+$HEIGHT]
  .c delete all
  .c create rectangle [expr $GLEFT-3] [expr $GTOP-$HEIGHT-15-3] [expr $GLEFT+$WIDTH+3] [expr $GTOP-15+3]
  for {set y 0} {$y<$height} {incr y} {
    for {set x 0} {$x<$width} {incr x} {
      set x1 [expr $GLEFT+$x*($GMARGIN+$GBOX)]
      set x2 [expr $x1+$GBOX]
      set y1 [expr $GTOP+$y*($GMARGIN+$GBOX)]
      set y2 [expr $y1+$GBOX]
      .c create rectangle $x1 $y1 $x2 $y2 -fill white -outline gray -tags $x,$y
    }
  }

  set HLEFT $FLEFT
  set HTOP [expr $FBOTTOM+$FTOP]

  #vertical line for marking font origin
  set x [expr $GLEFT-$xorg*($GMARGIN+$GBOX)]
  set y1 [expr $GTOP]
  set y2 [expr $GTOP+$height*($GMARGIN+$GBOX)]
  .c create line $x $y1 $x $y2 -width 2 -fill skyblue

  #horizontal line of font origin
  set x1 [expr $GLEFT]
  set x2 [expr $GLEFT+$width*($GMARGIN+$GBOX)]
  set y [expr $GTOP+($height+$yorg)*($GMARGIN+$GBOX)]
  .c create line $x1 $y $x2 $y -width 2 -fill skyblue

  .c create text [expr $GLEFT+$width+20] [expr $GTOP-$height-15-3] \
	    -anchor nw -text "" -tags charlabel
  .c create window 10 [expr $GTOP-20] -window .c.apply -anchor w
  .c create window 10 [expr $GTOP-20+30] -window .c.reset -anchor w
  .c create window 10 [expr $GTOP-20+60] -window .c.orig -anchor w
  .c create window 10 [expr $GTOP-20+90] -window .c.clear -anchor w
  .c create window 10 [expr $GTOP-20+120] -window .c.hold -anchor w
  .c config -width [expr $FRIGHT+$FLEFT]
  .c config -height [expr $GTOP+($GMARGIN+$GBOX)*$HEIGHT+$GPAD]
  .fc config -width [expr $FRIGHT+$FLEFT]
  #.fc config -height [expr $FBOTTOM+$FTOP]
  .fc config -height [expr $HTOP+$HEIGHT+$FTOP]

  set x [expr $GLEFT+$width*($GMARGIN+$GBOX)]
  set y1 [expr $GTOP-($GMARGIN+$GBOX)]
  set y2 [expr $GTOP+($height+1)*($GMARGIN+$GBOX)]
  .c create line $x $y1 $x $y2 -width 2 -fill green -tags dwidth

  set xbase [expr $GLEFT+($width-1)*($GMARGIN+$GBOX)+$GMARGIN]
  set xpoint [expr $GLEFT+$width*($GMARGIN+$GBOX)]
  set ypoint [expr $GTOP+($height+$yorg)*($GMARGIN+$GBOX)]
  set ybase1 [expr $ypoint-$GMARGIN*4]
  set ybase2 [expr $ypoint+$GMARGIN*4]
  .c create polygon $xbase $ybase1 $xbase $ybase2 $xpoint $ypoint -fill skyblue -tags dwidth

  .c bind charlabel <1> renamechar

  wm geometry . ""
}

proc adjustdwidth {x y} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT chardata currchar fontinfo
  set newx [expr ($x+($GMARGIN+$GBOX)/2-$GLEFT)/($GMARGIN+$GBOX)]
  set newx [expr $newx+$fontinfo(xorigin)]
  #if ($newx<0) { set newx 0 }
  #if ($newx>$WIDTH) { set newx $WIDTH }
  showdwidth $newx
  set chardata(dwidth,work) $newx
}

proc showdwidth {d} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT fontinfo
  .c delete dwidth

  set x [expr $GLEFT+($d-$fontinfo(xorigin))*($GMARGIN+$GBOX)]
  set y1 [expr $GTOP-($GMARGIN+$GBOX)]
  set y2 [expr $GTOP+($HEIGHT+1)*($GMARGIN+$GBOX)]
  .c create line $x $y1 $x $y2 -width 2 -fill green -tags dwidth

  set xbase [expr $GLEFT+($d-1-$fontinfo(xorigin))*($GMARGIN+$GBOX)+$GMARGIN]
  set xpoint [expr $GLEFT+($d-$fontinfo(xorigin))*($GMARGIN+$GBOX)]
  set ypoint [expr $GTOP+($HEIGHT+$fontinfo(yorigin))*($GMARGIN+$GBOX)]
  set ybase1 [expr $ypoint-$GMARGIN*4]
  set ybase2 [expr $ypoint+$GMARGIN*4]
  .c create polygon $xbase $ybase1 $xbase $ybase2 $xpoint $ypoint -fill skyblue -tags dwidth
}

proc oldsetgrid {data} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT
  for {set y 0} {$y<$HEIGHT} {incr y} {
    for {set x 0} {$x<$WIDTH} {incr x} {
      if [lindex [lindex $data $y] $x] {
	.c itemconfig $x,$y -fill black
      } else {
	.c itemconfig $x,$y -fill white
      }
    }
  }
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $data view
}

proc setgrid {varname key} {
  global GTOP GLEFT GMARGIN GBOX WIDTH HEIGHT chardata currchar
  global $varname
  set data [set ${varname}($key)]
  set x 0
  set y 0
  foreach row $data {
    foreach bit $row {
      if $bit {
	.c itemconfig $x,$y -fill black
      } else {
	.c itemconfig $x,$y -fill white
      }
      incr x
    }
    set x 0
    incr y
  }
  showchardata .c $GLEFT [expr $GTOP-$HEIGHT-15] $data view
  set name ""
  if [info exists ${varname}(name,$key)] {
    set name [set ${varname}(name,$key)]
  } elseif [info exists chardata(name,$currchar)] {
    set name $chardata(name,$currchar)
  }
  if [info exists ${varname}(dwidth,$key)] {
    showdwidth [set ${varname}(dwidth,$key)]
  } elseif [info exists chardata(dwidth,$currchar)] {
    showdwidth $chardata(dwidth,$currchar)
  } else {
    showdwidth $WIDTH
  }
  set txt [format "%d (%c) %s" $currchar $currchar $name]
  .c itemconfig charlabel -text $txt
}

#