#!../mofe --f
# derived from the tk program of Claudio Esperanca <esperanc@umiacs.umd.edu>
# modified for wafe by G.Neumann

set nx 10
set ny 25
set startdelay 350
set linesperlevel 50
set delayreduction 0.7
set scorecompleteline(0) 0
set scorecompleteline(1) 100
set scorecompleteline(2) 250
set scorecompleteline(3) 500
set scorecompleteline(4) 1000
set scoreperdropheight 10

fallbackResources topLevel \
    *f*foreground black \
    *f*background gainsboro \
    *f*XmTextField.background gray75 \
    *f*XmPushButton.background gray75 \
    *menubar*background gray70

mergeResources topLevel \
    *field*marginHeight 0 \
    *field*marginWidth 0 \
    *field*highlightThickness 0 \
    *field*recomputeSize False \
    *f*XmTextField.editable false \
    *field*labelString "" \
    *traversalOn False \
    *cursorPositionVisible False

set seed [pid]
proc random { nvalues } {
  global seed
  set seed [expr ($seed*12731+34197)%21473]
  return [expr $seed % $nvalues]
}

proc initpieces {} {
  global piece
  # pieces are defined as displacements from an anchor cell
  set piece(0) "{0 0} {+1 0} {-1 0} {-2 0}"
  set piece(1) "{0 0} {-1 0} {+1 0} {+1 -1}"
  set piece(2) "{0 0} {+1 0} {-1 0} {-1 -1}"
  set piece(3) "{0 0} {-1 0} {-1 -1} {0 -1}"
  set piece(4) "{0 0} {-1 0} {0 -1} {+1 -1}"
  set piece(5) "{0 0} {+1 0} {0 -1} {-1 -1}"
  set piece(6) "{0 0} {+1 0} {-1 0} {0 -1}"
  # compute set of rotated pieces
  for {set i 0} {$i < 21} {incr i} {
    set j [expr $i+7]
    if $i%7==3 {
      # rotating the square piece should have no effect
      set piece($j) $piece($i)
    } else {
      # apply 90 deg rotation
      foreach block $piece($i) {
	scan $block "%d %d" x y
	lappend piece($j) "[expr -$y] [expr $x]"
      }
    }
  }
}

proc loadimages {} {
  global tx ty img
  set i -1
  foreach color {brown deeppink green aquamarine navy cyan yellow} {
    set img([incr i]) $color
  }
  for {set i 7} {$i<=28} {incr i} { set img($i) $img([expr $i%7]) }
  set img(space) gray97
  set tx 23
  set ty 23
}

proc createfield {} {
  global nx ny tx ty img pixmaps
  set n 0
  for {set y 0} {$y<$ny} {incr y} {
    for {set x 0} {$x<$nx} {incr x} {
      XmPushButton t$n field \
	  x [expr $x*$tx] y [expr $y*$ty] width $tx height $ty
      set pixmaps(t$n) 0
      incr n
    }
  }
  clearfield
}

proc setPixmap {f pixmap} {
  global pixmaps
  if ![string compare $pixmap $pixmaps($f)] return
  XmChangeColor field*$f $pixmap
  switch $pixmap {
    gray97  { sV field*$f shadowThickness 1 }
    default { sV field*$f shadowThickness 3 }
  }
  set pixmaps($f) $pixmap
}

proc getPixmap {f} {
  global pixmaps
  return $pixmaps($f)
}

proc clearfield {} {
  global nx ny field img
  for {set n 0;set y 0} {$y<$ny} {incr y} {
    for {set x 0} {$x<$nx} {incr x} {
      setPixmap t$n $img(space)
      set field($n) 0
      incr n
    }
  }
}

proc inclevel {} {
  global level delay delayreduction
  incr level
  set delay [expr int($delay*$delayreduction)]
}

proc addtoscore { completelines dropheight } {
  global score level lines linesperlevel scorecompleteline scoreperdropheight
  incr score $scorecompleteline($completelines)
  incr score [expr $dropheight*$scoreperdropheight]
  incr lines $completelines
  if $lines/$linesperlevel>$level inclevel
}

proc piecelocus { ox oy p } {
  global piece nx ny field
  set locus {}
  foreach i $piece($p) {
    scan $i "%d %d" ix iy
    set x [expr $ox+$ix]
    set y [expr $oy+$iy]
    set l [expr $y*$nx+$x]
    if {$x<0||$x>=$nx||$y>=$ny||$y>=0 && $field($l)} return {}
    lappend locus $l
  }
  return $locus
}

proc drawpiece { locus what } {
  foreach l $locus { if $l>=0 { setPixmap t$l $what } }
}

proc drawpieces { new } {
  global img curpiece curlocus
  foreach x $new { set n($x) 1 }
  foreach x $curlocus {
    if $x<0 continue
    if [catch {unset n($x)}] { setPixmap t$x $img(space) }
  }
  drawpiece [array names n] $img($curpiece)
  return $new
}

proc setfield { locus what } {
  global field
  foreach l $locus { set field($l) $what }
}


proc startnewpiece {} {
  global curx cury curpiece nx curlocus
  set curx [expr $nx/2]
  set cury 0
  set curpiece [random 28]
  return [set curlocus [piecelocus $curx $cury $curpiece]]
}

proc testcomplete {} {
  global curx cury curpiece curlocus nx ny field img
  set complete {}
  set min [expr $nx*$ny]
  set max 0
  foreach i $curlocus {
    if $i<$min&&$i>=0 { set min $i}
    if $i>$max { set max $i}
  }
  set min [expr $min/$nx*$nx]
  set max [expr $max/$nx*$nx]
  for {set i $max} {$i>=$min} {incr i -$nx} {
    for {set j [expr $i+$nx-1]} {$j>=$i} {incr j -1} {
      if !$field($j) break
    }
    if $j<$i {
      lappend complete $i
      for {set j [expr $i+$nx-1]} {$j>=$i} {incr j -1} {
	setPixmap t$j $img(space)
	set field($j) 0
      }
    }
  }
  if [string match "" $complete] return
  addtoscore [llength $complete] 0
  for {set i [lindex $complete 0]} {$i>=0} {incr i -$nx} {
    lappend to $i
  }
  set from $to
  foreach i $complete {
    set j [lsearch -exact $from $i]
    set from [lreplace $from $j $j]
  }
  foreach i $from {
    set j [lindex $to 0]
    set to [lrange $to 1 end]
    for {set k 0} {$k<$nx} {incr k} {
      if [set field($j) $field($i)] {
	setPixmap t$j [getPixmap t$i]
      } else {
	setPixmap t$j $img(space)
      }
      incr i
      incr j
    }
  }
  foreach i $to {
    for {set k 0} {$k<$nx} {incr k} {
      set field($i) 0
      setPixmap t$i $img(space)
      incr i
    }
  }
}

proc movedown {} {
  global curx cury curpiece curlocus stat img
  incr cury
  set newlocus [piecelocus $curx $cury $curpiece]
  if [string match "" $newlocus] {
    setfield $curlocus 1
    testcomplete
    set stat rest
    return 0
  }
  set curlocus [drawpieces $newlocus]
  return 1
}

proc moveside { increment } {
  global curx cury curpiece curlocus img stat
  if [string compare $stat move] return
  set newlocus [piecelocus [expr $curx$increment] $cury $curpiece]
  if [string match "" $newlocus] return
  incr curx $increment
  set curlocus [drawpieces $newlocus]
}

proc turn { dir } {
  global curx cury curpiece curlocus img stat
  if [string compare $stat move]  return
  set newpiece [expr ($curpiece+((0$dir)*7)+28)%28]
  set newlocus [piecelocus $curx $cury $newpiece]
  if [string match "" $newlocus] return
  set curpiece $newpiece
  set curlocus [drawpieces $newlocus]
}


proc letfall {} {
  global cury ny stat playid delay
  if [string compare $stat move] return
  addtoscore 0 [expr $ny-$cury]
  set i 0
  while {[movedown]} {
    if ![string compare 0 [expr [incr i]%4]] {XmUpdateDisplay topLevel}
  }
  unset playid
  addTimeOut $delay { set playid 1;play}
}

proc fieldmsg { msg } {
  sV message labelString $msg
}

proc initinterface {} {
  set translations {#override
  <Key>j:     exec("moveside -1")
  <Key>l:     exec("moveside +1")
  <Key>i:     exec("turn -1")
  <Key>k:     exec("turn +1")
  <Key>n:     exec(start)
  <Key>p:     exec(dopause)
  <Key>b:     exec(inclevel)
  <Key>q:     exec(quit)
  }

  global nx ny tx ty score lines level
  XmMainWindow m topLevel translations $translations
   XmMenuBar menubar m
    XmPulldownMenu pulldown menubar unmanaged
    XmPushButtonGadget Left pulldown \
       accelerator <Key>Left \
       acceleratorText Left \
       activateCallback "moveside -1"
    XmPushButtonGadget Right pulldown \
       accelerator <Key>Right \
       acceleratorText Right \
       activateCallback "moveside +1"
    XmPushButtonGadget TurnLeft pulldown \
       accelerator <Key>Up \
       acceleratorText Up \
       activateCallback "turn -1"
    XmPushButtonGadget TurnRight pulldown \
       accelerator <Key>Down \
       acceleratorText Down \
       activateCallback "turn +1"
    XmPushButtonGadget Drop pulldown \
       accelerator <Key>space \
       acceleratorText Space \
       activateCallback "letfall"

    XmSeparatorGadget sep pulldown
    XmPushButtonGadget Quit pulldown \
       accelerator <Key>Left \
       acceleratorText Left \
       activateCallback quit
  XmCascadeButtonGadget Actions menubar subMenuId pulldown mnemonic A

  XmForm f m
  XmRowColumn rc f
  XmPushButton start  rc labelString "New Game" activateCallback dostart
  XmPushButton Pause  rc activateCallback dopause
  XmPushButton Quit   rc activateCallback quit
  XmLabel      Score: rc
  XmTextField  score  rc
  XmLabel      Lines: rc
  XmTextField  lines  rc
  XmLabel      Level: rc
  XmTextField  level  rc
  XmFrame frame f leftAttachment ATTACH_WIDGET leftWidget rc \
      width [expr $nx*$tx+2] height [expr $ny*$ty+2]
  XmBulletinBoard field frame
  XmLabel message rc
  foreach v {score lines level} { trace variable $v w changeField}
  createfield
  realize
}

proc changeField {var args} {
  global $var
  sV $var value [set $var]
}

proc play {} {
  global delay stat curlocus curpiece img playid
  if ![info exists playid] return
  switch $stat {
    rest {
      if [string match "" [startnewpiece]] {
	set stat finish
	doendgame
	return
      }
      set stat move
      drawpiece $curlocus $img($curpiece)
    }
    finish { return }
  }
  movedown
  set playid [addTimeOut $delay play]
}

proc doendgame {} {
  global playid
  fieldmsg "Game Over"
  unset playid
}


proc dostart {} {
  global lines score level delay startdelay playid stat
  set lines 0
  set level 0
  set score 0
  set delay $startdelay
  set stat rest
  fieldmsg ""
  set playid 1
  clearfield
  sV Pause labelString "Pause"
  addTimeOut $delay play
}

proc dopause {} {
  global playid stat
  if [info exists playid] {
    unset playid
    fieldmsg " ... PAUSED ..."
    sV Pause labelString "Continue"
  } else {
    sV message labelString ""
    sV Pause labelString "Pause"
    set playid 1
    play
  }
}

set score 0
set level 0
set lines 0
set stat finish
initpieces
loadimages
initinterface
fieldmsg "Press New Game"

