functor
require
DemoUrls(image)
import
FD
Space
Tk
TkTools
Application
prepare
URL = {VirtualString.toAtom DemoUrls.image # 'animated-queens/'}
MaxWidth = 600 %
FailWidth = 10
DefaultSize = 6 %
ParamWinTitle = 'Animated Queens: Size'
%% WidthByMag = s(micro:2 tiny:5 small:10 middle:25 large:50)
MaxBoardSize = 255
define
LargeFont = {New Tk.font tkInit(family:times weight:bold size:~24)}
BlackColor #
WhiteColor #
QueenColor #
CrossColor #
FailColor = if Tk.isColor then
gray85 # gray95 # darkorange1 # gray75 # firebrick
else black # white # black # black # black
end
QueenByMag = {List.toRecord ''
{Map [micro tiny small middle large]
fun {$ S}
S#{New Tk.image
tkInit(type:bitmap foreground:QueenColor
url: URL # S# '-queen.xbm')}
end}}
CrossByMag = c(micro: false
tiny: false
small: false
middle: {New Tk.image
tkInit(type:bitmap foreground:CrossColor
url: URL # 'middle-cross.xbm')}
large: {New Tk.image
tkInit(type:bitmap foreground:CrossColor
url: URL # 'large-cross.xbm')})
NaiveStrat = 1
FirstFailStrat = 2
UpFirstStrat = 3
MiddleOutStrat = 4
DefaultStrat = MiddleOutStrat
%% %% %%
local
fun {OrderUp X Y}
SizeX = {FD.reflect.size X}
SizeY = {FD.reflect.size Y}
in
SizeX < SizeY orelse
SizeX==SizeY andthen
{FD.reflect.min X} < {FD.reflect.min Y}
end
fun {QueensScript Size Strategy}
Distribute = case Strategy
of !NaiveStrat then naive
[] !FirstFailStrat then ff
[] !UpFirstStrat then generic(order:OrderUp)
[] !MiddleOutStrat then generic(value:mid)
end
in
proc {$ Xs}
Xs = {FD.list Size 1#Size}
{FD.distinct Xs}
{FD.distinctOffset Xs {List.number 1 Size 1}}
{FD.distinctOffset Xs {List.number Size 1 ~1}}
{FD.distribute Distribute Xs}
end
end
in
class Engine
feat
canvas
attr
Stack: nil
Stopped: false
meth init(Size Strategy Canvas)
S={Space.new {QueensScript Size Strategy}}
in
Stopped <- false
Stack <- [S]
self.canvas = Canvas
{self next}
end
meth next
case @Stack
of nil then
{self finish}
Stopped <- true
{self.canvas stop}
[] S|Sr then
if S==backtrack then
Stack <- Sr
{self backtrack}
Engine,next
else
{self show(S)}
case {Space.ask S}
of alternatives(M) then
C={Space.clone S}
in
{Space.commit S 1}
{Space.commit C 2#M}
Stack <- S|C|backtrack|Sr
[] failed then
Stack <- backtrack|Sr
[] succeeded then
Stack <- backtrack|Sr
Stopped <- true
{self.canvas stop}
end
end
end
end
meth sol
Engine, next
if @Stopped then skip else
Engine,sol
end
end
meth stop
Stopped <- true
end
meth start
Stopped <- false
end
end
end
local
fun {ReflectForCrosses Xs}
case Xs of nil then nil
[] X|Xr then {FD.reflect.domList X}|{ReflectForCrosses Xr}
end
end
fun {Reflect Xs}
case Xs of nil then nil
[] X|Xr then
if {FD.reflect.size X}==1 then X else void end|{Reflect Xr}
end
end
in
fun {MakePainter Canvas Mag Size}
Width = WidthByMag.Mag
Cross = CrossByMag.Mag
Queen = QueenByMag.Mag
Total = Size * Width
Fail0 = Total div 4
Fail1 = Fail0 + Total div 2
proc {DrawFail T}
{Canvas tk(create line Fail0 Fail0 Fail1 Fail1
width:FailWidth fill:FailColor capstyle:round tags:T)}
{Canvas tk(create line Fail0 Fail1 Fail1 Fail0
width:FailWidth fill:FailColor capstyle:round tags:T)}
end
proc {DrawQueen X Y T}
if X\=void andthen Y\=void then
{Canvas tk(create image (X-1)*Width (Y-1)*Width
image: Queen
tags: T
anchor: nw)}
end
end
UpdateBoard
ReflectBoard
if Cross\=false then
proc {DrawCross X Y T}
{Canvas tk(create image (X-1)*Width (Y-1)*Width
image: Cross
tags: T
anchor: nw)}
end
proc {DrawCrosses Os Ns I T}
case Os of nil then skip
[] O|Or then
case Ns of nil then {DrawCross O I T} {DrawCrosses Or Ns I T}
[] N|Nr then
{DrawCrosses Or if O<N then {DrawCross O I T} Ns
else Nr end I T}
end
end
end
in
proc {UpdateBoard Os Ns I T}
case Os of nil then skip
[] O|Or then N|Nr=Ns in
if O.2\=nil then
case N of [M] then
{DrawQueen M I T}
else skip
end
{DrawCrosses O N I T}
end
{UpdateBoard Or Nr I+1 T}
end
end
ReflectBoard = ReflectForCrosses
else
proc {UpdateBoard Os Ns I T}
case Os of nil then skip
[] O|Or then N|Nr=Ns in
if O\=N then
{DrawQueen N I T}
end
{UpdateBoard Or Nr I+1 T}
end
end
ReflectBoard = Reflect
end
in
class $
from Engine
attr Stack:nil
meth backtrack
case @Stack of nil then skip
[] S|Sr then {S.2 tkClose} Stack <- Sr
end
end
meth show(S)
NewT = {New Tk.canvasTag tkInit(parent:Canvas)}
in
case {Space.ask S}
of failed then
{DrawFail NewT}
Stack <- _#NewT|@Stack
else
NewB = {ReflectBoard {Space.merge {Space.clone S}}}
in
case @Stack of nil then
Stack <- [NewB#NewT]
[] OldB#_|_ then
{UpdateBoard OldB NewB 1 NewT}
Stack <- NewB#NewT|@Stack
end
end
end
meth finish
{Canvas tk(delete all)}
thread
{Canvas.sol tk(conf state:disabled)}
{Canvas.next tk(conf state:disabled)}
end
end
end
end
end
class Board
from Tk.canvas
prop
locking
attr
engine
size: DefaultSize
strategy: DefaultStrat
feat
stop
next
sol
toplevel
meth init(Top)
lock
self.toplevel = Top
StratVar = {New Tk.variable tkInit(DefaultStrat)}
Menu = {TkTools.menubar Top Top
[menubutton(text:'Queens' feature:queens
menu: [command(label: 'About Queens'
action: self # about)
command(label: 'Restart Search'
action: self # start)
separator
command(label: 'Quit'
action: self # close)])
menubutton(text:'Options' feature:options
menu: [radiobutton(label: 'No Heuristic'
var: StratVar
value: NaiveStrat
action:
self #
setStrategy(NaiveStrat))
radiobutton(label: 'Least First'
var: StratVar
value: FirstFailStrat
action:
self #
setStrategy(FirstFailStrat))
radiobutton(label: 'Smart Least First'
var: StratVar
value: UpFirstStrat
action:
self #
setStrategy(UpFirstStrat))
radiobutton(label: 'Middle First'
var: StratVar
value: MiddleOutStrat
action:
self #
setStrategy(MiddleOutStrat))
separator
command(label: 'Change Size'
action: self # setSize)])]
nil}
Frame = {New Tk.frame tkInit(parent: Top)}
Tk.canvas,tkInit(parent: Top
relief: sunken
bd: 2
xscrollincrement: 1
yscrollincrement: 1
highlightthickness: 0
background: WhiteColor)
{self tk(xview scroll ~2 units)}
{self tk(yview scroll ~2 units)}
Stop = {New Tk.button tkInit(parent: Frame
text: 'Stop'
state: disabled
action: self # stop)}
Next = {New Tk.button tkInit(parent: Frame
text: 'Next Step'
action: self # next)}
Sol = {New Tk.button tkInit(parent: Frame
text: 'Next Solution'
action: self # sol)}
in
{Menu.options.menu tk(conf tearoff:false)}
{Menu.queens.menu tk(conf tearoff:false)}
{Tk.batch [pack(Menu side:top fill:x)
pack(Stop Next Sol fill:x side:left)
pack(self Frame padx:4 pady:4 side:top)]}
self.stop = Stop
self.next = Next
self.sol = Sol
Board,start
end
end
meth setStrategy(Strat)
lock
strategy <- Strat
Board,stop
Board,start
end
end
meth setSize
lock
Size
Dialog = {New TkTools.dialog
tkInit(title: ParamWinTitle
master: self.toplevel
buttons: ['Okay' #
tkClose(proc {$}
Size={Top tkReturnInt(get $)}
end)]
pack: false
focus: 1
default: 1)}
Frame = {New TkTools.textframe tkInit(parent: Dialog
text: 'Board Size')}
Top = {New Tk.scale tkInit(parent: Frame.inner
'from': 4
to: MaxBoardSize
length: 8#c
orient: horizo
showvalue: true)}
in
{Top tk(set @size)}
{Tk.batch [pack(Top) pack(Frame fill:both)]}
{Dialog tkPack}
{Wait Size}
size <- Size
Board,stop
Board,start
end
end
meth about
lock
Dialog = {New TkTools.dialog tkInit(title: ParamWinTitle
buttons: ['Okay' # tkClose]
default: 1
focus: 1
master: self.toplevel)}
TitleAndQueen = {New Tk.frame tkInit(parent: Dialog)}
Title = {New Tk.label tkInit(parent: TitleAndQueen
font: LargeFont
fg: blue
text: 'Animated Queens')}
Queen = {New Tk.label tkInit(parent: TitleAndQueen
image: QueenByMag.large)}
Author = {New Tk.label tkInit(parent: Dialog
text:('Christian Schulte\n' #
'(schulte@dfki.uni-sb.de)\n'))}
in
{Tk.batch [pack(Queen Title
side:left fill:both ipadx:2#m ipady:2#m)
pack(TitleAndQueen Author
side:top padx:2#m pady:2#m)]}
{Wait Dialog.tkClosed}
end
end
meth start
lock
Size = @size
Strat = @strategy
Mag = if Size*WidthByMag.large =<MaxWidth then large
elseif Size*WidthByMag.middle=<MaxWidth then middle
elseif Size*WidthByMag.small =<MaxWidth then small
elseif Size*WidthByMag.tiny =<MaxWidth then tiny
else micro
end
MagWidth = WidthByMag.Mag
Width = Size*MagWidth
in
{self tk(delete all)}
{self tk(configure width:Width height:Width)}
{For 0 Size-1 2
proc {$ I}
{For 1 Size-1 2
proc {$ J}
{self tk(crea rectangle
I*MagWidth J*MagWidth
(I+1)*MagWidth (J+1)*MagWidth
fill:BlackColor outline:'')}
end}
end}
{For 1 Size-1 2
proc {$ I}
{For 0 Size-1 2
proc {$ J}
{self tk(crea rectangle
I*MagWidth J*MagWidth
(I+1)*MagWidth (J+1)*MagWidth
fill:BlackColor outline:'')}
end}
end}
{self.sol tk(conf state:normal)}
{self.next tk(conf state:normal)}
engine <- {New {MakePainter self Mag Size}
init(Size Strat self)}
end
end
meth stop
{@engine stop}
{self.stop tk(conf state:disabled)}
end
meth next
lock
{self.sol tk(conf state:disabled)}
{self.next tk(conf state:disabled)}
{@engine next}
{self.sol tk(conf state:normal)}
{self.next tk(conf state:normal)}
end
end
meth sol
lock
{self.sol tk(conf state:disabled)}
{self.next tk(conf state:disabled)}
{self.stop tk(conf state:normal)}
{@engine start}
{@engine sol}
{self.sol tk(conf state:normal)}
{self.next tk(conf state:normal)}
end
end
meth close
lock
{Application.exit 0}
end
end
end
Top = {New Tk.toplevel tkInit(title: 'Animated Queens'
delete: Application.exit # 0)}
{New Board init(Top) _}
end