4-gram Game

tk4gram.tcl

#!/usr/bin/wish
# @(#)tk4gram, v1.2 2000-02-26 Bluebat
set Program Tk4gram
set Version 1.2
set Data $Program.dat
set Font {Lucida 12 bold}
set F {Lucida 10}
#====================== arguments =========================
for {set x 0} {$x < $argc} {incr x} {
  switch -- [lindex $argv $x] {
    -data {set Data [lindex $argv [incr x]]}
    default {
      puts stderr "用法: $Program \[-data %s\]"
      exit 1
    }
  }
}
set Modellist {}
if [file isfile $Data] {
  set d [open $Data r]
  while {[gets $d l]!=-1} {lappend Modellist [split $l]}
  close $d
} else {
  lappend Modellist {超級 -2 2 1 -1 0 1 1 -2 1 0 1 0}
  lappend Modellist {女人 1 -2 5 0 -1 5 1 1 1 -2 1 2}
  lappend Modellist {男人 3 0 3 0 2 2 2 -1 0 0 -1 3}
  lappend Modellist {舟 4 0 2 -3 -1 1 3 -1 1 0 -1 2}
  lappend Modellist {炸彈 0 3 2 0 -1 0 2 -2 2 -1 2 1}
  lappend Modellist {蝴蝶 -2 4 2 -1 3 4 2 -3 2 0 0 3}
  lappend Modellist {七 0 3 3 1 -2 3 1 1 2 -3 3 5}
  lappend Modellist {八 0 1 1 2 -2 3 0 -1 2 -2 3 5}
  lappend Modellist {箭頭 -1 5 3 -2 4 3 2 -4 3 -2 0 0}
  lappend Modellist {隱形戰機 -1 0 5 -2 3 1 1 -3 5 0 1 4}
  lappend Modellist {鑽石 0 3 5 -1 0 4 2 0 5 -1 2 4}
  lappend Modellist {海鷗 -4 4 2 5 -5 1 -2 2 3 1 -1 4}
  lappend Modellist {回收 1 -3 2 0 2 4 -1 0 5 3 -2 2}
  lappend Modellist {鰭 1 -2 4 -1 -1 0 0 2 1 1 -1 0}
  lappend Modellist {魚 -1 4 5 -1 2 3 1 -2 3 1 0 0}
  lappend Modellist {塔 -1 -2 4 -1 2 5 3 -1 0 -1 0 5}
  lappend Modellist {金魚 1 -3 5 1 1 3 -1 0 5 2 -2 4}
  lappend Modellist {舢 -2 1 4 -2 -1 2 3 -1 4 0 0 3}
  lappend Modellist {花瓶 -1 3 1 1 -3 5 -1 2 0 0 -1 1}
  lappend Modellist {山 2 -3 2 4 -2 5 -1 -2 4 1 0 4}
  lappend Modellist {蛇 1 -3 5 -3 4 5 -1 1 0 3 -3 3}
  lappend Modellist {船 -2 -1 5 2 0 2 3 -2 1 0 -1 3}
  lappend Modellist {指標 -2 -1 1 0 -1 5 -1 1 1 2 0 0}
  lappend Modellist {丫 1 -4 1 -2 2 1 1 2 2 1 -1 3}
  lappend Modellist {蝙蝠 2 2 4 -2 1 3 0 0 2 2 0 5}
  lappend Modellist {花 -1 2 2 0 -1 4 1 1 2 -2 1 1}
  lappend Modellist {折 2 1 3 -1 -1 5 -2 1 1 2 -1 1}
  lappend Modellist {勝利 1 -3 1 1 2 0 -3 2 3 1 -1 2}
  lappend Modellist {鳥 0 -1 0 -3 3 5 3 -2 3 -1 1 5}
  lappend Modellist {火 1 1 4 0 -3 1 -1 1 2 3 -2 3}
  lappend Modellist {四邊形 2 1 1 -2 -1 5 -1 1 4 2 -1 2}
  lappend Modellist {梯形 4 -2 2 -2 -1 5 -1 1 4 2 -1 2}
}
#=============================== initial ===============================
set Blockdata(0) {2 1 5 5 3 3}
set Blockdata(1) {5 3 3 1 1 0 0 5 5 3}
set Blockdata(2) {4 3 3 1 1 0 0 0 0 4 4 3}
set Blockdata(3) {0 5 5 3 3 2 2 1 1 0 0 4}
set Model 0
set Block 0
set Name 未知
set Userlist {未知 -2 -3 2 1 2 5 3 -3 4 -3 2 0}
set Marked 0
#=============================== widget ===============================
wm title . $Program
wm resizable . 0 0
canvas .c -width 300 -height 300 -relief sunken -bd 2 -bg wheat
frame .f
pack .c .f -side left -fill y
bind .c <Button1-Motion> "Move_Block %x %y"
bind .c <ButtonRelease-1> "set Marked 0"
entry .f.name -textvar Name -width 10 -bg white -font $F
button .f.insert -text 新增 -command "Make_List insert" -font $Font
button .f.delete -text 刪除 -command "Make_List delete" -font $Font
button .f.last -text 前項 -command "incr Model -1; Show_Model" -font $Font
button .f.next -text 後項 -command "incr Model; Show_Model" -font $Font
label .f.label -text "" -bg white -font $F
canvas .f.c -width 100 -height 100 -bg wheat
button .f.about -text 關於 -command "About $Program $Version" -font $Font
button .f.exit -text 結束 -command exit -font $Font
pack .f.name .f.insert .f.delete .f.last .f.next .f.label .f.c .f.about .f.exit -fill x -expand 1
#=============================== procedure ===============================
proc Mark_Block {b} {
  global Blocktag Block Marked
  set Marked 1
  set Block $b
  .c raise $Blocktag($Block)
}

proc Make_Block {c b l} {
  global Blockdata Blocktag
  set x [lindex $l 0]
  set y [lindex $l 1]
  set a [lindex $l 2]
  set tl {}
  foreach i $Blockdata($b) {
    switch -exact [expr ($i-[lindex $Blockdata($b) 0]+$a)%6] {
      0 {incr x}
      1 {incr y}
      2 {incr x -1; incr y}
      3 {incr x -1}
      4 {incr y -1}
      5 {incr x; incr y -1}
    }
    lappend tl $x $y
  }
  set s [expr [string compare $c model]?3:1]
  foreach {x y} $tl {
    lappend pl [expr ($x*2+$y)*8*$s/sqrt(3)+50*$s] [expr (50-$y*8)*$s]
  }
  return $pl
}

proc Move_Block {x y} {
  global Userlist Blocktag Marked Block
  if $Marked&&$x>0&&$x<300&&$y>0&&$y<300 {
    set nx [expr round((($x-150)*sqrt(3)-(150-$y))/48.0)]
    set ny [expr round((150-$y)/24.0)]
    set a [lindex $Userlist [expr $Block*3+3]]
    set Userlist [lreplace $Userlist [expr $Block*3+1] [expr $Block*3+2] $nx $ny]
    set l [Make_Block user $Block [list $nx $ny $a]]
    eval .c coords $Blocktag($Block) $l
  }
}

proc Rotate_Block {} {
  global Userlist Blocktag Block Marked
  if $Marked {
    set Marked 0
    set x [lindex $Userlist [expr $Block*3+1]]
    set y [lindex $Userlist [expr $Block*3+2]]
    set b [expr $Block*3+3]
    set a [expr ([lindex $Userlist $b]-1)%6]
    set Userlist [lreplace $Userlist $b $b $a]
    set l [Make_Block user $Block [list $x $y $a]]
    eval .c coords $Blocktag($Block) $l
  }
}

proc Show_Model {} {
  global Modellist Model
  .f.c delete all
  if [llength $Modellist]==0 {
    .f.label config -text "0"
  } else {
    set Model [expr $Model%[llength $Modellist]]
    set bl [lindex $Modellist $Model]
    .f.label config -text "[expr $Model+1] [lindex $bl 0]"
    foreach b {0 1 2 3} {
      set l [lrange $bl [expr $b*3+1] [expr $b*3+3]]
      set pl [Make_Block model $b $l]
      eval .f.c creat polygon $pl -fill green4
    }
  }
}

proc Make_List {f} {
  global Modellist Userlist Model Name Data
  if [string compare $f delete] {
    if ![string compare $Name ""] {set Name Unknown}
    set Userlist [lreplace $Userlist 0 0 $Name]
    set Modellist [linsert $Modellist $Model $Userlist]
  } else {
    set Modellist [lreplace $Modellist $Model $Model]
  }
  Show_Model
  set d [open $Data w]
  foreach l $Modellist {puts $d $l}
  close $d
}

proc About {p v} {
  global F Font
  .f.about config -state disabled
  wm title [toplevel .about] About
  wm resizable .about 0 0
  message .about.copyleft -justify center -aspect 250 -text "\n$p  $v     GPL (c) 2000\n" -font $F
  message .about.name -justify center -aspect 250 -text "四塊板" -font $Font
  message .about.me -justify center -aspect 250 -text "\n趙惟倫\n<[email protected]>\n" -font $F
  message .about.tip -justify center -aspect 250 -text "\n以滑鼠左鍵來移動板子\n以滑鼠右鍵來轉動板子\n" -font $F
  button .about.b -text 關閉 -relief groove -command {
    destroy .about
    .f.about config -state normal
  }
  pack .about.copyleft .about.name .about.me .about.tip .about.b -fill both
}
#=============================== main ===============================
Show_Model
foreach Block {0 1 2 3} {
  set l [lrange $Userlist [expr $Block*3+1] [expr $Block*3+3]]
  set pl [Make_Block user $Block $l]
  set Blocktag($Block) [eval .c creat polygon $pl -fill green4 -outline black]
  .c bind $Blocktag($Block) <ButtonPress> "Mark_Block $Block"
  .c bind $Blocktag($Block) <ButtonRelease-3> "Rotate_Block"
  .c bind $Blocktag($Block) <Enter> ".c config -cursor hand2"
  .c bind $Blocktag($Block) <Leave> ".c config -cursor top_left_arrow"
}