Tetris.oz

% Un tetris tout à fait normal.
%
% Mon record est de 7 lignes.
%
% Le programme est un peu lent au début.
%
% Je n’ai pas fait en sorte que les blocs commencent à tomber plus vite toutes
% les 10 lignes. Aucun être humain ne l’a encore remarqué. Allez savoir
% pourquoi.

declare

% Game logic

EmptyCell     = 0
MovingCell    = 1
FilledCell    = 2
CollidingCell = MovingCell + FilledCell

fun {EmptyGrid W H}
   grid({NewArray 0 (W*H)-1 EmptyCell#black} width: W height: H)
end

fun {MapGrid F grid(B width: W height: H)}
   OutBuffer = {NewArray 0 (W*H)-1 EmptyCell#black}
in
   for Y in 0..(H-1) do
      for X in 0..(W-1) do
         {Array.put OutBuffer Y*W+X {F {Array.get B Y*W+X} X Y}}
      end
   end

   grid(OutBuffer width: W height: H)
end

fun {MapBlock F Block}
   {List.mapInd
    Block
    fun {$ Y L}
       {List.mapInd L fun {$ X C} {F C X-1 Y-1} end}
    end}
end

fun {FoldGrid F Acc grid(B width: W height: H)}
   fun {FoldLine Acc Y X}
      if X == W then Acc
      else {FoldLine {F Acc {Array.get B Y*W+X} X Y} Y X+1}
      end
   end

   fun {FoldMat Acc Y}
      if Y == H then Acc
      else {FoldMat {FoldLine Acc Y 0} Y+1}
      end
   end
in
   {FoldMat Acc 0}
end

fun {Colorize Color Block}
   {MapBlock
    fun {$ D _ _} if D == MovingCell then D#Color else D#black end end
    Block}
end

IBlock = {Colorize cyan
          [[0 0 0 0]
           [1 1 1 1]
           [0 0 0 0]
           [0 0 0 0]]}
OBlock = {Colorize yellow
          [[1 1]
           [1 1]]}
TBlock = {Colorize purple
          [[0 0 0]
           [1 1 1]
           [0 1 0]]}
SBlock = {Colorize green
          [[0 0 0]
           [0 1 1]
           [1 1 0]]}
ZBlock = {Colorize red
          [[0 0 0]
           [1 1 0]
           [0 1 1]]}
LBlock = {Colorize orange
          [[0 1 0]
          [0 1 0]
          [0 1 1]]}
JBlock = {Colorize blue
          [[0 1 0]
           [0 1 0]
           [1 1 0]]}

Blocks = [IBlock JBlock LBlock TBlock OBlock SBlock ZBlock]

fun {FindLines F grid(B width: W height: H)}
   fun {Valid Y X}
      if X == W then true
      elseif {F {Array.get B Y*W+X} X Y} then {Valid Y X+1}
      else false
      end
   end

   fun {Find Y}
      if Y == H then nil
      else
         if {Valid Y 0} then Y|{Find Y+1}
         else {Find Y+1}
         end
      end
   end
in
   {Find 0}
end

fun {CountInGrid F Grid}
   {FoldGrid fun {$ Count C#_ X Y}
                if {F C X Y} then Count+1
                else Count
                end
             end 0 Grid}
end

fun {IsValidGrid Grid}
   {CountInGrid fun {$ C _ _} C == MovingCell end Grid} == 4
end

fun {GetInBlock Block X Y}
   {List.nth {List.nth Block Y+1} X+1}
end

fun {GetInGrid grid(B width: W height: H) X Y}
   {Array.get B Y*W+X}
end

fun {InsertBlock Grid Block BlockX#BlockY}
   BlockH = {List.length Block}
   BlockW = {List.length Block.1}
in
   {MapGrid
    fun {$ Cell#OldColor X Y}
       if BlockX =< X andthen X < BlockX+BlockW andthen
          BlockY =< Y andthen Y < BlockY+BlockH then
          Val#Color = {GetInBlock Block X-BlockX Y-BlockY} in
          (Val+Cell)#(if Val > EmptyCell then Color
                      else OldColor
                      end)
       else
          Cell#OldColor
       end
    end
   Grid}
end

fun {FixBlock Grid}
   {MapGrid
    fun {$ Cell#Color _ _}
       if Cell == MovingCell then FilledCell#Color
       else Cell#Color
       end
    end Grid}
end

fun {RemoveClearedLines Grid}
   ClearedLines = {FindLines fun {$ C#_ _ _} C == FilledCell end Grid}
in
   {List.foldL ClearedLines
    fun {$ Grid LineY}
       {MapGrid fun {$ Cell X Y}
                   if Y =< LineY then
                      if Y == 0 then EmptyCell#black
                      else {GetInGrid Grid X Y-1}
                      end
                   else Cell
                   end
                end Grid}
    end Grid}#{List.length ClearedLines}
end

fun {ShiftBlock Grid Block BlockX#BlockY DeltaX#DeltaY}
   NewX = BlockX+DeltaX
   NewY = BlockY+DeltaY
in
   if {IsValidGrid {InsertBlock Grid Block NewX#NewY}} then
      NewX#NewY
   else
      BlockX#BlockY
   end
end

fun {ShiftBlockToDirection Grid Block BlockX#BlockY Dir}
   {ShiftBlock Grid Block BlockX#BlockY
    case Dir
    of left  then ~1#0
    [] right then 1#0
    [] down  then 0#1
    end}
end

fun {RotateBlock Block}
   Size = {List.length Block}
in
   {MapBlock
    fun {$ _ X Y} {GetInBlock Block (Size-Y-1) X} end
    Block}
end

fun {TryRotateBlock Grid Block X#Y}
   NewBlock = {RotateBlock Block}
in
   if {IsValidGrid {InsertBlock Grid NewBlock X#Y}} then
      NewBlock
   else
      Block
   end
end

% Hash table implementation (for more efficient sets)

declare

class LinkedList
   attr key value next

   meth init(K V)
      key   := K
      value := V

      next := null
   end

   meth key(K)
      K = @key
   end

   meth value(V)
      V = @value
   end

   meth next(N)
      N = @next
   end

   meth insert(K V WasThere)
      if {Not {K equal(@key $)}} then
         if @next == null then
            next := {New LinkedList init(K V)}
            WasThere = false
         else {@next insert(K V WasThere)}
         end
      else
         WasThere = true
      end
   end

   meth delete(K V WasThere)
      if @next == null then
         WasThere = false
         V = null
      elseif {{@next key($)} equal(K $)} then
         {@next value(V)}
         WasThere = true

         next := {@next next($)}
      else  {@next delete(K V WasThere)}
      end
   end

   meth find(K V)
      if {@key equal(K $)} then V = @value
      elseif @next == null  then V = null
      else {@next find(K V)}
      end
   end

   meth forall(P)
      {P @key @value}
      if @next \= null then {@next forall(P)} end
   end
end

class Hashtable
   attr buffer size capacity

   meth init
      size     := 0
      capacity := 16

      buffer := {Array.new 0 @capacity-1 null}
   end

   meth rehash
      NewCapacity = @capacity * 2
      NewBuffer = {Array.new 0 NewCapacity-1 null}

      OldCapacity = @capacity
      OldBuffer = @buffer
   in
      size     := 0
      capacity := NewCapacity

      buffer := NewBuffer

      for I in 0..(OldCapacity-1) do
         Bucket = {Array.get OldBuffer I} in
         if Bucket \= null then
            {Bucket forall(proc {$ K V} {self set(K V)} end)}
         end
      end
   end

   meth set(K V)
      if @size == @capacity then {self rehash} end
      I {self findIndex(K I)} in {self addToBucket(I K V)}
   end

   meth get(K V)
      I {self findIndex(K I)} in {self findInBucket(I K V)}
   end

   meth delete(K V)
      I {self findIndex(K I)} in {self deleteFromBucket(I K V)}
   end

   meth forall(P)
      for I in 0..(@capacity-1) do
         Bucket = {Array.get @buffer I} in
         if Bucket \= null then
            {Bucket forall(P)}
         end
      end
   end

   meth findIndex(K I)
      H {K hash(H)} in I = if H > 0 then H mod @capacity
                           else ~(H mod @capacity)
                           end
   end

   meth addToBucket(I K V)
      Bucket = {Array.get @buffer I} in
      if Bucket == null then {Array.put @buffer I {New LinkedList init(K V)}}
      else
         if {Bucket insert(K V $)} then
            size := @size + 1
         end
      end
   end

   meth findInBucket(I K V)
      Bucket = {Array.get @buffer I} in
      if Bucket == null then V = null
      else {Bucket find(K V)}
      end
   end

   meth deleteFromBucket(I K V)
      Bucket = {Array.get @buffer I} in
      if Bucket == null then V = null
      elseif {{Bucket key($)} equal(K $)} then
         {Array.put @buffer I {Bucket next($)}}
         size := @size - 1
      elseif {Bucket delete(K V $)} then
         size := @size - 1
      end
   end
end

% Block selection algorithm
% Computes the worst block possible for the current grid :)
% Like Bastet: http://fph.altervista.org/prog/bastet.html

class BlockPosition
   attr orientation pos blockType

   meth init(Orientation Pos BlockType)
      @orientation = Orientation
      @pos         = Pos
      @blockType   = BlockType
   end

   meth equal(O R)
      R = @pos == {O pos($)} andthen
          @orientation == {O orientation($)}
   end

   meth hash(R)
      X#Y = @pos
   in R = X*64+Y*2+@orientation
   end

   meth orientation(O) O = @orientation end
   meth pos(P) P = @pos end
   meth blockType(T) T = @blockType end

   meth successors(S)
      X#Y = @pos

      Block = {self block($)}
      RotatedBlock = {RotateBlock Block}
   in
      S = {List.map
           {List.filter [0#1#false 1#0#false 0#1#false 0#0#true]
            fun {$ DeltaX#DeltaY#Rotate}
               {IsValidGrid
                {InsertBlock
                 @Grid if Rotate then RotatedBlock
                       else Block
                       end
                 (X+DeltaX)#(Y+1)}}
            end}
           fun {$ DeltaX#DeltaY#Rotate}
              {New BlockPosition
               init((@orientation + if Rotate then 1
                                    else 0
                                    end) mod 4
                    (X+DeltaX)#(Y+DeltaY)
                    @blockType)}
           end}
   end

   meth isGoal(R)
      X#Y = @pos
   in R = {Not {IsValidGrid {InsertBlock @Grid {self block($)} X#(Y+1)}}}
   end

   meth block(B)
      fun {Rotate N Block}
         if N == 0 then Block
         else {Rotate N-1 {RotateBlock Block}}
         end
      end
   in
      B = {Rotate @orientation @blockType}
   end

   % High score means good for the player
   meth evaluate(S)
      LineCoeff          = 100000000
      EmptyCellAboveCoef = 10000

      NewGrid#Lines = {RemoveClearedLines
                       {FixBlock {InsertBlock @Grid {self block($)} @pos}}}

      fun {EmptyCellsScore}
         fun {Iter Empty Current Y}
            if Y == Height then Current
            else
               StillEmpty = {List.mapInd Empty
                             fun {$ X C} C andthen
                                {GetInGrid NewGrid X-1 Y}==EmptyCell
                             end}
               Count = {List.foldL StillEmpty
                        fun {$ C State}
                           if State then C+1
                           else C
                           end
                        end 0}
            in
               {Iter StillEmpty
                Current + EmptyCellAboveCoef * Count
                Y+1}
            end
         end

         fun {MakeEmpty N}
            if N == 0 then nil
            else true|{MakeEmpty N-1}
            end
         end
      in
         {Iter {MakeEmpty Width} 0 0}
      end
   in
      S = Lines * LineCoeff + {EmptyCellsScore} * EmptyCellAboveCoef
   end
end

fun {TreeSearch States Combiner Found Visited}
   if States == nil then Found
   else
      S|Sr = States
      SeenBefore = {Visited get(S $)} == true
   in
      if SeenBefore then
         {TreeSearch Sr Combiner Found Visited}
      else
         {Visited set(S true)}

         if {S isGoal($)} then {TreeSearch {Combiner {S successors($)} Sr}
                                Combiner S|Found Visited}
         else {TreeSearch {Combiner {S successors($)} Sr}
               Combiner Found Visited}
         end
      end
   end
end

fun {DepthFirstSearch Start}
   {TreeSearch [Start] List.append nil {New Hashtable init}}
end

fun {ScoreFor Block}
   fun {Maximum Xs}
      case Xs
      of X|Xr then {List.foldL Xr Max X}
      else 0
      end
   end
in
   {Maximum
    {List.map {DepthFirstSearch {New BlockPosition init(0 0#0 Block)}}
     fun {$ P} {P evaluate($)} end}}
end

fun {FindWorstBlock}
   fun {FindIndex X Ps}
      fun {Iter P|Pr N}
         if P >= X then N
         else {Iter Pr N+1}
         end
      end
   in {Iter Ps 1}
   end

   Scores = {List.mapInd Blocks
             fun {$ I B}
                % Randomized tie handling
                thread ({ScoreFor B} + {OS.rand} mod 100)#I end
             end}
   SortedScores = {List.sort Scores fun {$ S1#B S2#B} S1 < S2 end}
   % ^ Reverse this list to compute the *best* block     ^ <= make this a '>'

   Probabilities = [70 82 95 100 100 100 100]
   X = {OS.rand} mod 100

   ChosenOne = {FindIndex X Probabilities}

   _#BlockIndex = {List.nth SortedScores ChosenOne}
in
   {List.nth Blocks BlockIndex}
end

fun {NextBlock}
% The easy algorithm…
%    I = {OS.rand} mod {List.length Blocks}
% in
%    {List.nth Blocks I+1}

% And the fun one :D
   {FindWorstBlock}
end

fun {FirstBlock}
   {List.nth Blocks 1 + {OS.rand} mod 4}
end

% GUI

PixelSize = 32

Width  = 10
Height = 20

Grid     = {NewCell nil}
Score    = {NewCell nil}
Block    = {NewCell nil}
BlockPos = {NewCell nil}

Canvas    = {NewCell nil}
CanvasTag = {NewCell nil}

StillRunning = {NewCell false}
Lost         = {NewCell false}

TetrisLock = {NewLock}

LoopInterval = 300

proc {ResetGame}
   Grid     := {EmptyGrid Width Height}
   Score    := 0
   Block    := {FirstBlock}
   BlockPos := 0#0

   StillRunning := true
   Lost         := false
end

fun {CompleteGrid}
   {InsertBlock @Grid @Block @BlockPos}
end

proc {Render}
   grid(B width: W height: H) = {CompleteGrid}
in
   {@Canvas tk(delete @CanvasTag)}
   for Y in 0..(H-1) do
      for X in 0..(W-1) do
         FromX = PixelSize*X
         FromY = PixelSize*Y
         ToX   = PixelSize*(X+1)
         ToY   = PixelSize*(Y+1)
      in
         case {Array.get B Y*W+X}
         of !CollidingCell#_ then
            {@Canvas tk(create rectangle
                        FromX FromY ToX ToY
                        fill: gray tags: @CanvasTag)}
         [] _#Color then
            {@Canvas tk(create rectangle
                        FromX FromY ToX ToY
                        fill: Color tags: @CanvasTag)}
         else skip
         end
      end
   end
end

proc {DropBlock}
   lock TetrisLock then
      OldPos = @BlockPos
   in
      BlockPos := {ShiftBlockToDirection @Grid @Block @BlockPos down}

      if OldPos == @BlockPos then
         Grid := {FixBlock {CompleteGrid}}
         {HandleClearedLines}
         {Render}

         BlockPos := 0#0
         Block    := {NextBlock}

         {Render}

         if {Not {IsValidGrid {InsertBlock @Grid @Block @BlockPos}}} then
            Lost := true
         end
      end
   end
end

proc {HandleClearedLines}
   NewGrid#Lines = {RemoveClearedLines @Grid}
in
   Grid  := NewGrid
   Score := @Score + Lines
end

fun {PickFortune}
   Fortunes = ["You will do better next time!"
               "Tough luck!"
               "It's as if the game is trying to make you lose!"
               "Are you trying to keep the blocks in the well?"
               "By the way, the goal is *not* to build a high tower."
               "In golf, you try to keep a low score. This isn't golf."
               "Don't feel bad. I too used to suck at video games."
               "Tip: try and complete a line to play longer."
               "Did you know? When you complete a line, it is removed from the matrix!"]
in
   {List.nth Fortunes 1 + {OS.rand} mod {List.length Fortunes}}
end

proc {RunGameLoop}
   if @StillRunning then
      StartTime EndTime
   in
      StartTime = {Property.get 'time.total'}
      {DropBlock}
      {Render}
      EndTime = {Property.get 'time.total'}

      if @Lost then
         local
            Window = {New Tk.toplevel tkInit(title: 'Game over')}
            Msg = {New Tk.label
                   tkInit(parent: Window
                          text: "Your score was: "#@Score#"\n"#{PickFortune})}
         in
            {Tk.send pack(Msg side: left padx:2#m pady:2#m)}
         end

         StillRunning := false
      else
         {Time.delay
          {Max 0 LoopInterval - (EndTime - StartTime)}}
         {RunGameLoop}
      end
   end
end

proc {OnPress K}
   lock TetrisLock then
      case K
      of "Left" then
         BlockPos := {ShiftBlockToDirection @Grid @Block @BlockPos left}
         {Render}
      [] "Right" then
         BlockPos := {ShiftBlockToDirection @Grid @Block @BlockPos right}
         {Render}
      [] "Down" then
         BlockPos := {ShiftBlockToDirection @Grid @Block @BlockPos down}
         {Render}
      [] "Up" then
         Block := {TryRotateBlock @Grid @Block @BlockPos}
         {Render}
      else skip
      end
   end
end

proc {Tetris}
   Window = {New Tk.toplevel tkInit(title: 'Tetris')}
   Canvas := {New Tk.canvas tkInit(parent: Window
                                   width: Width*PixelSize
                                   height: Height*PixelSize)}
   CanvasTag := {New Tk.canvasTag tkInit(parent: @Canvas)}
in
   {Window
    tkBind(event: '<KeyPress>'
           args: [string('K')]
           action: OnPress)}

   {Tk.send pack(@Canvas)}

   {OS.srand {Time.time}}
   {ResetGame}
   thread {RunGameLoop} end
end

{Tetris}