{-# LANGUAGE CPP, BlockArguments, LambdaCase, TupleSections #-}
import Data.Char (chr, ord)
import Data.Foldable (asum)
import Control.Applicative (Alternative(..), liftA2)
import Data.Map ((!), Map, fromList, toAscList, insert)
import qualified Data.Map as M
mlookup = M.lookup
#define Ring Num
#include "zfc.hs"
A PuzzleScript experiment
Controls:
-
Move: arrow keys.
-
Restart: R
-
Undo: Z
-
Quit: Q or Escape.
== title Simple Block Pushing Game == author David Skinner == homepage www.puzzlescript.net ======== OBJECTS ======== Background LIGHTGREEN GREEN 11111 01111 11101 11111 10111 Target DarkBlue ..... .000. .0.0. .000. ..... Wall BROWN DARKBROWN 00010 11111 01000 11111 00010 Player Black Orange White Blue .000. .111. 22222 .333. .3.3. Crate Orange Yellow 00000 0...0 0...0 0...0 00000 ======= LEGEND ======= . = Background # = Wall P = Player * = Crate @ = Crate and Target O = Target Thing = Player or Wall or Crate ====== RULES ====== [ > Player | Crate ] -> [ > Player | > Crate ] [ > Thing | no Thing ] -> [ | Thing ] win [ Target no Crate ] unwin ======= LEVELS ======= ####.. #.O#.. #..### #@P..# #..*.# #..### ####.. ###### #....# #.#P.# #.*@.# #.O@.# #....# ######
== Based on:
== title Simple Block Pushing Game
== author David Skinner
== homepage www.puzzlescript.net
== Sasquatch levels from https://www.sourcecode.se/sokoban/levels
========
OBJECTS
========
Background
LIGHTGREEN GREEN
1111111111
1111111111
0111111111
1111111111
1111111011
1111111111
1111111111
1111111111
1101111111
1111111111
Target
DarkBlue
.....
.000.
.0.0.
.000.
.....
Wall
BROWN DARKBROWN
00000100
00000100
11111111
01000000
01000000
01000000
11111111
00000100
Player
Black Orange White Blue
....00000000....
....00000000....
....11111111....
...1110110111...
...1110110111...
....11111111....
......1111......
...2222222222...
.22222222222222.
222..222222..222
11...222222...11
....33333333....
....33333333....
....333..333....
....000..000....
...0000..0000...
Crate
Orange Yellow
00000
0...0
0...0
0...0
00000
=======
LEGEND
=======
# = Wall
@ = Player
$ = Crate
. = Target
* = Crate and Target
Thing = Player or Wall or Crate
======
RULES
======
[ > Player | Crate ] -> [ > Player | > Crate ]
[ > Thing | no Thing ] -> [ | Thing ]
win
[ Target no Crate ] unwin
=======
LEVELS
=======
###
## # ####
## ### #
## $ #
# @$ # #
### $### #
# #.. #
## ##.# ##
# ##
# ##
#######
## #####
## ## . #
# ## $. #
## $ #
## $@ ###
# $ ##
#.. ## ##
# # ##
##### #
#####
## #
# #
#### # $ ##
# ####$ $#
# $ $ #
## ## $ $ $#
# .# $ $ #
# .# #
##### #########
#.... @ #
#.... #
## ######
####
###########
## # @#
### $ $$# #
# ##$ $$ #
# # $ # #
###### ######
#.. ..$ #*##
# .. ###
# ..#####
#########
###########
## # ##
### $ $#$ $ ###
# #$ $ # $ $# #
# $ ..#.. $ #
# $...#...$ #
# $ .. * .. $ #
###### @ ######
# $ .. .. $ #
# $...#...$ #
# $ ..#.. $ #
# #$ $ # $ $# #
### $ $#$ $ ###
## # ##
###########
###########
###. .$. .###
## $ $ $ ##
## ..$.. ##
##$#$#$##
#.$ $.#
# @ #
### ###
## $ $ ##
#. $ .#
### . ###
#####
######
#### ## #
### # # ## ###
### #### # $ #
# $ @ ...*.. $ #
# $ $ ## ### ###
### ### # #####
# ###
# ####
#####
#######
# ##
##### ### ##
# # ##
#@$***. ##$ #
# # ## .#
## ## # $ #
## ####.$.#
## #
###### ##
####
#########
#. . #
#.$. . #
## ###@ #
# $ ##
# $$ ##
# $ #
# ###
####
######
# #
# @ ###
#### # #
# ####..#.#$#####
# $ $ ##... #
# .....#$$ #
###### ##$## #####
# $ #
#### ####
# #
# #####
### $ #
# $ $ #
# #$# ####
# #
#######
####
### ####
# @ ##
# #. .#.###
# $$$ $$$ #
###.#.#.# #
## #
#### ###
####
#####
# #
##### # #######
# ##### # ..... #
##### # ## # # # # #
# $ $ $ $ $ # ## ## $ #
# # ##......#### ### $$ ###
# ## * # # # $$ #
##########+$$ ## # #
#.$ $# # ########
#.## #
########
#######
### ##
# ### #
# # #
###$#@ # #
# ##### #
# # *. #
##$$# *.##
# *..#
#### #...##
# #$$$ #
# $ #
##### #
####
#######
## # #
# *.$.#
# *.#.###
# #$@$$ #
# ## # #
###### #
#####
####
#@ #
## #
# .$#
#$. #
###..$###
# ..$ #
# $ $ # #
##### # #
# #
#####
######
## # ###
## # # ##
# # $.# #
## $ $.# #
# #####. ##
# $. @#
# $. ####
### # #*# # ###
#### .$ #
# .$ #
## .##### #
# #.$ $ ##
# #.$ # #
## # # ##
### # ##
######
###########
## . . . . ###
# $$ $ $ $ #
# ######## # #####
#### ## $ # # #
# # $ $ # ### # #
## # # #### $ #
#... ##### $ #### ###
#... @ $ # #
#...############ $ $ #
##### ##### #
####
####
##### #
# #
#$ $ $ #
#.*.*.*#
#*.*.*.#
# $ $ $#
#......#
#.*.*.*#
#$ $ $ #
# $ $ $#
#$ $ $ #
# #
#@ #####
####
#####
# #######
# $ ##
## ###### ##
# # # # ########
# # ## $ ##
# #. #@###### $ ##
# #.# ### ## $ ##
# #. # ## $ ##
# #.# # ## ## $ ##
## #.# ## ### ## $ #
# #.# # #*## ## #
# .# # # ##*## #####
###### # ######
#####
####
# #
######$.#
# $ $.#
# $@$...#
# $$$..##
# $ ..#
########
##### ########
# ### . $ #
# $ *.. #$ ##
## $# ..* $ @#
# $ . ### #
######## #####
##### ####
#@ .### ###
#### $$ $ #
# # . . ## #
# $ # . . ## #
## . $ $$ # #
# # ###. # #
# #### ##### #
# # #
####### # ####
# .$ #
#### #
## #####
###
#######
###### ######
# . ..$#$.. . #
# $ $ . $ $ #
###$####@####$###
# $ $ . $ $ #
# . ..$#$.. . #
###### ######
#######
######
# ##
####### $ #
# $ $ $ #$ #
# #. $ #
####.#.# $###
# ..... #
# $ ..##$#
### ## .. #
# $.#$ # $#
# $ # #
##@ # ####
## ####
####
#####
##### #####
# .#$ $ #
# #. $$$ @ ##
# .#$ $ #
###.# $ $ #
#. ##$ ###
#######*###.$ #
# $ ....####
## #$#$$....#
# $ $ #..#
# $ #..#
# ##########
#####
####
########### #
# $ $ $ $ ##
# # # # # #$##
##. . . . . .#
#$# # # # #$####
###. . . . . . #
###$# # # # # @ #
# $ $ $ $ ###
# ###########
####
########
###### ##########
## $ ### ##
# $ $ ## # ######### #
# $ # # #
# $ $ # # ######### # #
# $ # # #. . . . # #
# $ $ # # . . . .## #
# $ # # # . . . . # #
##$ $## # #### # # ##
# #@ # # ####
###### ##### # #
## # # #
##### ## ##
## ##
######
######
# ###
##### $ $ #
#### #.# ##
# $ #$#.##$#####
# $$. .#.$ ##
# $.#.#.##### ####
## ....... @# #
####$ #.### #$###$##
## $ . # $ $ $ #
# $ ### #
# # ############
#####
####
# # ####
# ######## ####### #
# ### ## $ #
##.###### ... #. #
#.# # .# # $ #
#$$$$#$$$ #.# ##. #
#.# $ $ #.. ##
#.# $ $ # # ##
# # $$ # #####
#. ##$ ######
#. # $. #
##. @ ###.#$ #
# # # #
# ## ######
######
#####
# #
# # ######
### ## ##### # ###
# # ## #$$ #
##$ ########## $ $ #
### ## ..........$ #$$@#
# # $$# ####### $ #
# $ #...# ### ####
# # $ ### ## ####
######## #
# #
# #
######
#########
### ## ####
##### # * ## # #
# #### **** ####$.##
# .$ *@* $. #
##.$#### **** #### #
# # ## * # #####
#### ## ###
#########
#####
# #
######### $ #
###### # # # #
# # # $ $ #@#
### ## #### ### ## ###
# $ $ # # #
# $ $ # #$ # $$ $$ #
###### $ # # # #
## ## ###############
# .# $ # #
#.. # ######
#...#### #
#....# ####
#....#
######
#######
## ##
# ### #
# ## $ ####
# # .# $.####
# # * *###.$ #
# # *# ### #####
# # @ * * # # #
# # ### #*# * #
# ## # * *.# # #######
# # # ....$ $ #
# # ## $# $####$ #
###* * # #######
# ########## ####
# #
## ############
####
#####
# ..########
# ......# #
#.. ##$$ $#
#####.## $ #
# ....# $ $$#
##### ## # .. .#$ $ #
# # # ##.### $$ $###
# ### # ## # $ # #
# @ #### # # # ###$ # #
# # $ $ #
# #### ### ####$$##
# ## #### # #
# # ## ###### #
#### ## # # $ #
## # # #
###### #####
#####
# #
## # #####
# ## #######
# # $ ####
# #### $ $$ # #
##### # $$$ $ #$ #
# $ $ $ $ ######
###$ #$ $ $ #
# $ $$ ### @ ##
# $ $$$$####... #
# $ $ #. .#...#
### $$$$ ...... #
# ##..#.....#
###### ##.....####
# .....# #
##########
#####
#### # ######
# # # $ $ #
# #### # $##$ ###
# ######### # $ $ #
# ..........# $ #
###### ##....@### # $$ #
# # #####.## # ## $ #
# # #$ $$ $ #
#### # ##### # # $ # #
# # # # ### ####
# # # # #####
# # #####
##### #
#######
##### #########
# # # #
### #$### ##### # # # #####
# $. . # # . . . . #
# # # #$### # # # # # # #$#
# . . . . $ $ $ $ . . #
###$# # #$###########$# #$#
# . . ## # . #
###$# #$####### # #$# #$###
# . .$ $ $ # # . . #
#$# # # # # #####$# # # #
# . . . . . $ . . . #
### # # # # # # # # # # #
# $ $. . .$ $ $ $ $ $ #
##### # # #############
# @ #
#######
####
#### ######## #
###@ ## # # #
# # # ### $ $ #
# ....########## # #..#
# . # ## $ $ $# # #..#
### # $ $$$ # # $ $ #
# ...# $ $$ # # # #
# ..# $ $ $ # # ## #
##...# $ $$ $ #$# #####
# ## $ $ $ # #
### ###### ### # ###
# . ## #### . . #
## . # # #.#.# #
# . # # # # # #
# . #### #########
# ##
####
#### #####
# ####### #### #
# @ $ #### $ #
# ###.# # $$ #
###.## $ #$ # # ##
# ..# $ ...# ### ##
# $ ...$##.## ##
##.###$ $.. $$ ##
#. #. .### $ $ #
# $...## ## # #
## ###### # ##
## ## #####
# $$ #
# $ #
### $ #
# ##
####
#######
#### # #
# ### $$$ #
# ....$ #####
# ..# $ # @#
###$##$#### # ######
#.*....$ $ ### #####
# ..##### ## $ $ #
#....*.... # $$ # $ #
########## #$$ ## # #
# $.### $ ##
# $###$# # #
##### $ $ ####
#### ####
######
#####
# #
### ########
## *** # # #
# * * ## # #####
## *** ## # ## ##
### #### # # # #
# # # # ####$ $###
## ## # ## $...$ ##
##### # ## .@. #
# # # $...$ ##
########$ $###
# #
#####
####
# ######
# ####
# $ $ # #####
##### ### $ #
# # $ # #
# ##$######
# $### # ...# #
## #@#$ ##.#.# #
# # #...# #
# $ ##$ $#...#####
### ## #... #
# # $ $ $ # # #
# $### ###### # #
# # #
############# #
#####
####
## #############
## .......... #
## # ####$### ##
# # # # ##
# # # $$$ # # #####
##### # . .# ### . . . ##
# $. .# # $$ $ $ @#
####### ### # #######
# $ $ # ## ###
# $ $ # # ## # ####
# $### #### # # # ## ####
# $ $$$ # ## # ## #
## # ## #### $$$ #
## ####### ..... #####
# $ ###### #
# ###### ## ####
##### ####
#############
## # ###
# $ $$$$$ #
### $ $ ### #
# $ $ $### # #
## $ ## # ###
#### #### #
### # ###
#### #### #
#@ $ ### #.# #####
# $ $ ## # .... #
# $$ ## ####..... #
## $ # #..#.## #
# $ $ ## #...... #
# $ $ # # . ..# ##
## $ # ## ##.# #
# ## # #
###### ########
#### ########
# ##### ## # #
# $ ### $ $ #
# $ # ## $ ####
### # # ###$## #
##### ### #### $ #
# # $ $$## .. ##$ #
# $$ # $ ##
## # $## #### # ####
### # ##$ ###..#..#
# ###.. # .....###
# # *.### # #.. #
##$$# *.##@ # # #
# *. #### ### #
###### # # #
##### ## ###
# ###
####
#### ###################
##### ### .$ #
### $. #####$#### # #
# $. #### # . ### .#
# $ $.### ## # #### # $.# $#
### $.## # # # # # # $ # #
###### # ## #$ $ ## #. # #
##### #.#. # ### # #
##### # # ### ### # #
##*## # .# # #$$* ##
#*### ### ## ## ## # .#. ##
###*# # .$ .# $.$.## ### #
##*## # #.#### # $. ##
#*### # $$ ### ### ## ##
###*# # # . $@$ #######. #
##### # ### ####.# $ #
# # ########### #
####### ####
#########
# # ######
# $ ###### ###
# #$#$ $ $ # $ #
# $ $@$ $ $ $ $$ #
# $ $# $ # $$$ #
# $ $ ####### #####
## ###....##### ..#
###$$# $$$$ #...* ..#
# ## #.. #
# # #$###....##*##
# ##..$. .... #
### .* .#....# #
##################
#### ####
## # # # #######
### ###$ ## # ###
# $ $ ### #
# $ $ ###$ # # #
### ### # # # #
# $ # ## ### # ###
# $ # #@ ##
# $# # ### ### # #
# $ # # $ $ # # # #
## # $ # #. #
## # # ## #.. ###
## # # ## #... ##
### # #### #....##
# $.*.##
############..##
####
#########################
# # # # # # # # #
# $#$ # $#$ # $#$ # $#$ #
# # # # # # # # #
## # ### # ### # ### # ##
# # # # # # # # #
# # # # #
# ### # ### # ### # ### #
# # # # # # # # #
# # # $ # # #
# # ### # ### # ### # #
# . . . . + . . . . #
#########################
# # # # # # # # # # # #
# # # # # # # # # # # # #
# .$ . $. . $ .$ #
# $# #$# # # #$# # # # #
# . . $. . .$ . . #
# #$# # # # #$#$ $# #$# #
# . .$ .$ . $. . #
# $# # # # #@# # # # #$ #
# . .$ . $. $. . #
# #$# #$ $#$# # # # #$# #
# . . $. . .$ . . #
# # # # #$# # # #$# #$ #
# $. $ . .$ . $. #
# # # # # # # # # # # # #
# # # # # # # # # # # #
== title Match 3 Block Push == author Stephen Lavelle == homepage www.puzzlescript.net ======== OBJECTS ======== Background LIGHTGREEN GREEN 11111 01111 11101 11111 10111 Target DarkBlue ..... .000. .0.0. .000. ..... Wall BROWN DARKBROWN 00010 11111 01000 11111 00010 Player Black Orange White Blue .000. .111. 22222 .333. .3.3. Crate Orange Yellow 00000 0...0 0...0 0...0 00000 ======= LEGEND ======= . = Background # = Wall P = Player * = Crate @ = Crate and Target O = Target Solid = Player or Wall or Crate ====== RULES ====== [ > Player | Crate ] -> [ > Player | > Crate ] [ > Solid | stationary solid ] -> [ Solid | Solid ] [ > Solid | ] -> [ | Solid ] [ Crate | Crate | Crate ] -> [ | | ] win [ Crate no Target ] unwin ======= LEVELS ======= ######### #.......# #.*.*.@.# #.P...O.# #...*.*.# #.......# ######### .#######. .#.....#. .#O##..## ##.##.*.# #.*..**.# #.OOO.#.# #.P.....# #########
== title Block Faker == author Droqen == homepage www.droqen.com == https://droqen.itch.io/block-faker == require_player_movement == key_repeat_interval 0.12 == background_color white == text_color black == color_palette c64 ======== OBJECTS ======== Background White Grille gray 0...0 .0.0. ..0.. .0.0. 0...0 EndPoint Green Player Black 00000 00000 0.0.0 00000 00000 Wall Gray WallBlock Black Grey 01111 01111 01111 01111 00001 BlueBlock Blue 00000 00.00 0.0.0 00.00 00000 GreenBlock LightGreen 00000 00000 00.00 00000 00000 PinkBlock Red 00000 00.00 0...0 00.00 00000 PurpleBlock Purple 00000 0...0 0.0.0 0...0 00000 OrangeBlock Orange 00000 0.0.0 00000 0.0.0 00000 ======= LEGEND ======= Block = PinkBlock or BlueBlock or PurpleBlock or OrangeBlock or GreenBlock Moveable = Player or Block Immovable = Wall or WallBlock . = Background # = Wall @ = WallBlock P = Player B = BlueBlock G = GreenBLock K = PinkBlock R = PurpleBlock O = OrangeBlock E = EndPoint x = Grille H = Grille and Player == Player, Wall, WallBlock, PinkBlock, BlueBlock, PurpleBlock, OrangeBlock, GreenBlock ====== RULES ====== [ > Moveable | Moveable ] -> [ > Moveable | > Moveable ] [ > Block | Grille ] -> [ Block | Grille ] [ > Moveable | Immovable ] -> [ Moveable | Immovable ] [ > Moveable | no Moveable ] -> [ | Moveable ] [ PinkBlock | PinkBlock | PinkBlock ] -> [ | | ] [ BlueBlock | BlueBlock | BlueBlock ] -> [ | | ] [ PurpleBlock | PurpleBlock | PurpleBlock ] -> [ | | ] [ OrangeBlock | OrangeBlock | OrangeBlock ] -> [ | | ] [ GreenBlock | GreenBlock | GreenBlock ] -> [ | | ] [ player endpoint ] win ======= LEVELS ======= ........######## ################ ########@@@@@### ####@@@@@...@### ###@..OO....@@## ##@..@@@@@....@# ##@.@..@@@..E@@# #@..@.O...@@@@## ##@...@.P.###### ####@.@@@@###### ####@@########## ########........ ########## ####R.R### #x....#x## #xO#O.OxE# #xx##.#xx# #####R#### #####P#### O######### ......#######... .....##P.#####.. ....###....####. ..#####O...#B..# ..#####.#.##BB.# ##EBB..O.O.....# ..#####.#.#....# ..######..#G.### ....####..#.OOx. .....###.GG.#x.. ......#######... ######xx###### ######GG###### ##xx#...#xEx## ##..O...#x..## ##..#...##O### #..##.......## xG....##....Gx xG....##....Gx ##.......GG### ###G##...#xx## ##x..#...O.x## ##.P.#...#xx## ######GG###### ######xx###### ......##...... ....######.... ..##########.. ..#.OG..kk.#.. .##OPO..Gkk##. .##GOG..GGk##. ###...##...### ###...##...### .##kkG##ROR##. .##Gkk..OEO##. ..#.Gk..RO.#.. ..##########.. ....######.... ......##......
== Based on: == title Iterated Extended Rigid Body Test == author Scott Hughes ======= OBJECTS ======= Background white Player pink Player2 pink Box1 red Box2 green Wall grey Register grey ====== LEGEND ====== . = Background @ = Player ! = Player2 1 = Box1 2 = Box2 # = Wall $ = Register Box = Box1 or Box2 Thing = Box or Player or Player2 ===== RULES ===== [ moving Player ] [ Register ] -> [ moving Player ] [ moving Register ] [ > Player | Box ] -> [ > Player | > Box ] [ moving Box1 | Box1 ] -> [ moving Box1 | moving Box1 ] [ moving Box2 | Box2 ] -> [ moving Box2 | moving Box2 ] [ > Box | Box ] -> [ > Box | > Box ] [ moving Box1 | Box1 ] -> [ moving Box1 | moving Box1 ] [ moving Box2 | Box2 ] -> [ moving Box2 | moving Box2 ] [ > Thing | Wall ] -> [ Thing | Wall Halt ] [ Halt ] [ moving Thing ] -> [ Halt ] [ Thing ] [ Halt ] -> [ ] [ > Thing | no Thing ] -> [ | Thing ] [ > Register ] [ Player2 ] -> [ > Register ] [ > Player2 ] [ > Player2 | Box ] -> [ > Player2 | > Box ] [ moving Box1 | Box1 ] -> [ moving Box1 | moving Box1 ] [ moving Box2 | Box2 ] -> [ moving Box2 | moving Box2 ] [ > Box | Box ] -> [ > Box | > Box ] [ moving Box1 | Box1 ] -> [ moving Box1 | moving Box1 ] [ moving Box2 | Box2 ] -> [ moving Box2 | moving Box2 ] [ > Thing | Wall ] -> [ Thing | Wall Halt ] [ Halt ] [ moving Thing ] -> [ Halt ] [ Thing ] [ Halt ] -> [ ] [ > Thing | no Thing ] -> [ | Thing ] ====== LEVELS ====== ########### #....#....# #.2..#....# #.2..#.11.# #....#..#.# #....#.2..# #.111#.22.# ##1..#..2.# #....#....# #.!..#..@.# #....#...## #....#....# $##########
PuzzleScript is a game engine that gets incredible mileage from a simple two-dimensional search-and-replace operation. We build a crude clone that pushes its core concept further:
-
Instead of a move phase, we use ordinary patterns to describe movement.
-
This obivates the need for the late keyword, as we have full control over when movement occurs.
-
We can do without the collisionlayer section because we bring our own collision rules.
-
Instead of the dedicated wincondition sublanguage, we use ordinary patterns to describe them by making the win action set a flag indicating victory and an unwin action that clears this flag. (Perhaps win could take an integer argument describing the number of levels to skip, which would allow level branching.)
Controlling movements with ordinary rules allows extended rigid bodies and extended movements. For the latter, to jump exactly 4 tiles in the air, we can place a hidden object 4 tiles away from an obstacle. A rule starts the object moving when the player does, and another rule stops the player when the object does.
Converting PuzzleScript
Our simplistic parser is fussy. A comment is a line starting with an equals sign. Block comments are unsupported.
Whitespace is significant. Tokens in the rules section must be separated by at least one space.
There is no support for the prelude. Comment each of these lines. Also, messages are unimplemented; comment them out.
The order of the OBJECTS matters. The first object is always drawn; it acts as the default background. Later objects are drawn on top of earlier objects if both are present in the same square.
Sprites can be bigger or smaller than 5x5, but ought to be square.
Remove the SOUNDS section. The prototype lacks support for sounds.
Remove the COLLISIONLAYERS section. For each layer that matters to the game, define a new entry in the LEGEND section, replacing each comma with or.
Replace the WINCONDITIONS with rules in the RULES section.
Only 4 sections should remain: OBJECTS LEGEND RULES LEVELS.
Basic Example
The basic example contains the COLLISIONLAYERS:
Background Target Player, Wall, Crate
We add a LEGEND entry for the last of the layers. It’s the only one that affects gameplay, so we throw the rest away:
Thing = Player or Wall or Crate
We add a corresponding moving rule. A Thing moves if its destination contains no Thing:
[ > Thing | no Thing ] -> [ | Thing ]
We translate the win condition:
All Target on Crate
to the following rules:
win [ Target no Crate ] unwin
In other words, we set the victory flag, but then unset it if we find a Target with no Crate on it.
To summarize, after the conversion, we have these rules:
[ > Player | Crate ] -> [ > Player | > Crate ] [ > Thing | no Thing ] -> [ | Thing ] win [ Target no Crate ] unwin
Implementation
For a while, I’ve been seeking an excuse to use Gaussian integers to index a 2D grid. More recently, I’ve been seeking for tests for my Haskell compiler. PuzzleScript appeared on my radar at a perfect time!
My compiler worked well enough (amazingly, I only ran into one bug), though the generated code is slow.
The engine compiles in GHC with this wrapper:
[+] Show engine
data Zi = Zi { re :: Int, im :: Int }
instance Ring Zi where
Zi a b + Zi c d = Zi (a + c) (b + d)
Zi a b * Zi c d = Zi (a * c - b * d) (a * d + b * c)
Zi a b - Zi c d = Zi (a - c) (b - d)
fromInteger x = Zi (fromInteger x) 0
instance Show Zi where
showsPrec _ (Zi a b) = shows a . (" + "++) . shows b . ('i':)
instance Eq Zi where Zi a b == Zi c d = a == c && b == d
instance Ord Zi where Zi a b <= Zi c d = if a == c then b <= d else a <= c
data Action s = Sub [[s]] | Cmd String
instance Show s => Show (Action s) where
showsPrec _ = \case
Sub subs -> ("Sub "++) . shows subs
Cmd s -> ("Cmd "++) . shows s
data Rule s = Rule (Maybe (Zi, [[[s]]])) (Action s)
instance Show s => Show (Rule s) where
showsPrec _ (Rule m a) = case m of
Nothing -> shows a
Just (dir, pats) -> shows dir . (' ':) . shows pats
data Game = Game
{ _objects :: [(String, ([String], [String]))]
, _legend :: [(String, RHS)]
, _astRules :: [[Rule (String, String)]]
, _astLevels :: [[String]]
}
instance Show Game where showsPrec _ (Game a b c d) = ("Game "++) . shows a . (" "++) . shows b . (" "++) . shows c . (" "++) . shows d
data RHS = Single String | And [String] | Or [String]
instance Show RHS where
showsPrec _ = \case
Single s -> ("Single "++) . shows s
And ss -> ("And "++) . shows ss
Or ss -> ("Or "++) . shows ss
data Fun = Stay | Move Zi
instance Eq Fun where
Stay == Stay = True
Move z == Move z' = z == z'
_ == _ = False
instance Show Fun where
showsPrec _ = \case
Stay -> ("Stay"++)
Move i -> ("Move "++) . shows i
data Board = Board
{ _hist :: (Map Zi [Int], [Map Zi [Int]])
, _level :: Int
, _dim :: (Int, Int) -- width x height
, _status :: String
}
zi = Zi 0 1
loadLevel g n = Board (fromList $ snd lvl, []) n (fst lvl) "" where
lvl = _levels g !! n
dump g board = unlines $ _status board : [[foldr (\c _ -> draw c) '.' $ fst (_hist board) ! Zi x y | x <- [0..w - 1]] | r <- [1..h], let y = h - r]
where
draw s = head $ show s
(w, h) = _dim board
step g z (Board (zcs, hist) lvl dim st) = Board (map snd <$> board, zcs:hist') lvl dim status
where
(status, board) = next g (st, move g z zcs)
hist' = if length hist == 100 then take 50 hist else hist
next g = foldr (\r fut -> fut . fixsub r) id $ _rules g
move g dz zcs = map go <$> zcs where
go c = if isplayer c then (Move dz, c) else (Stay, c)
isplayer c = c `elem` _playerIndexes g
oops (Board hist@(_, rest) x y z) = Board bs x y z where
bs = case rest of
[] -> hist
h:t -> (h, t)
isAnyMove (Move _) = True
isAnyMove _ = False
isMove d (Move d') | d == d' = True
isMove _ _ = False
isStay Stay = True
isStay _ = False
fixsub grp x
| changed = fixsub grp x'
| otherwise = x'
where
(changed, x') = foldl
(\(c, b) rule -> let (c', b') = obey b rule in (c || c', b'))
(False, x) grp
perform (_, board) (Cmd "win") = (False, ("won", board))
perform (_, board) (Cmd "unwin") = (False, ("", board))
obey x (Rule Nothing action) = perform x action
obey x@(status, board) (Rule (Just (dir, pats)) action) = case match board pats ixs dir of
[] -> (False, x)
zbinds -> case action of
Sub rpat -> maybe (False, x) ((True,) . (status,)) $ asum $ go rpat <$> zbinds
_ -> perform x action
where
ixs = fst <$> toAscList board
go rpat zb = if changed then Just board' else Nothing
where
(changed, board') = foldr alter (False, board) $ sub zb rpat
globs = concat $ snd <$> zb
sub [] [] = []
sub ((z, binds):bt) (rh:rt) = (z, alts) : sub bt rt
where
rres = map (\(PatVar f c _) -> (resolve c, resolveFun f)) rh
alts = [(c, Nothing) | (_, c) <- snd <$> binds, maybe True (const False) $ lookup c rres] ++ rres
resolve v = maybe v snd $ lookup v binds <|> lookup v globs
resolveFun "" = Just $ maybe Stay fst $ lookup (0-1) binds
resolveFun ">" = Just $ Move dir
resolveFun "no" = Nothing
resolveFun "moving" = Just $ maybe (error "BUG!") fst $ lookup (0-2) binds <|> lookup (0-2) globs
resolveFun s = Just $ maybe Stay Move $ lookup s dirTab
eqFCs xs ys = length xs == length ys && all (`elem` ys) xs
alter (z, edicts) (changed, st) = (changed || not (eqFCs before after), insert z after st)
where
before = st!z
after = foldl go before edicts
go fcs (c, m) = maybe id (\f -> ((f, c):)) m $ filter ((/= c) . snd) fcs
match st pats ixs d = case pats of
[] -> [[]]
p:rest -> [bs ++ morebs | z <- ixs, bs <- lineMatch st p d z, morebs <- match st rest ixs d]
getFC [] c = []
getFC ((f, c'):rest) c
| c == c' = [f]
| otherwise = getFC rest c
lineMatch st pat d z = case pat of
[] -> [[]]
clause:rest -> case mlookup z st of
Nothing -> []
Just fcs ->
[(z, binds):t | binds <- findBinds clause fcs, t <- lineMatch st rest d (z + d)]
where
solve (PatVar fpat bindme cands) fcs = let
withDir d = [[(bindme, (f, c))] | c <- cands, f <- getFC fcs c, isMove d f]
in case fpat of
"no" -> case concatMap (getFC fcs) cands of
[] -> [[]]
_ -> []
"" -> [[(0-1, (f, c)), (bindme, (f, c))] | c <- cands, f <- getFC fcs c]
">" -> withDir d
"stationary" -> [[(bindme, (f, c))] | c <- cands, f <- getFC fcs c, isStay f]
"moving" -> [[(0-2, (f, c)), (bindme, (f, c))] | c <- cands, f <- getFC fcs c, isAnyMove f]
_ -> maybe [] withDir $ lookup fpat dirTab
findBinds clause fcs = case clause of
[] -> [[]]
cl : rest -> [b ++ bt | b <- solve cl fcs, bt <- findBinds rest fcs]
-- Parser
toLower c
| 'A' <= c && c <= 'Z' = chr (ord c + 32)
| otherwise = c
data Parser s a = Parser ([s] -> Either String (a, [s]))
instance Functor (Parser s) where fmap f x = pure f <*> x
instance Applicative (Parser s) where
pure x = Parser \inp -> Right (x, inp)
x <*> y = Parser \inp -> case unParser x inp of
Left e -> Left e
Right (fun, t) -> case unParser y t of
Left e -> Left e
Right (arg, u) -> Right (fun arg, u)
instance Monad (Parser s) where
return = pure
(>>=) x f = Parser \inp -> case unParser x inp of
Left e -> Left e
Right (a, t) -> unParser (f a) t
instance Alternative (Parser s) where
empty = Parser \_ -> Left ""
x <|> y = Parser \inp -> either (const $ unParser y inp) Right $ unParser x inp
unParser (Parser f) = f
parse f inp = fst <$> unParser f inp
sepBy1 p sep = liftA2 (:) p (many (sep *> p))
sepBy p sep = sepBy1 p sep <|> pure []
between x y p = x *> (p <* y)
eof = Parser \s -> case s of
[] -> Right ((), s)
_ -> Left "want eof"
sat f = Parser \s -> case s of
[] -> Left "EOF"
h:t -> if f h then Right (h, t) else Left "unsat"
comment s = case s of
'=':_ -> True
_ -> False
blankLines = many $ sat null <|> sat comment
anything = sat $ const True
bad s = Parser $ const $ Left s
script = do
blankLines
foldr ($) (Game [] [] [] []) <$> some do
name <- map toLower <$> anything
case lookup name sectParsers of
Nothing -> bad "want section name"
Just p -> blankLines *> p
sectParsers =
[ ("objects", (\a (Game _ b c d) -> Game a b c d) <$> parseObjects)
, ("legend" , (\b (Game a _ c d) -> Game a b c d) <$> parseLegend)
, ("rules" , (\c (Game a b _ d) -> Game a b c d) <$> parseRules)
, ("levels" , (\d (Game a b c _) -> Game a b c d) <$> parseLevels)
]
isSectName s = map toLower s `elem` (fst <$> sectParsers)
parseObjects = some do
name <- identifier
cs <- words <$> anything
pix <- many (sat $ not . null)
sat null
blankLines
pure (name, (cs, pix))
parseLegend = some $ (<* blankLines) $
either bad pure . parse legEqn . words =<< anything
legEqn = do
lhs <- identifier <* word "="
rhs1 <- identifier
rhs <- And . (rhs1:) <$> some (word "and" *> identifier)
<|> Or . (rhs1:) <$> some (word "or" *> identifier)
<|> pure (Single rhs1)
eof
pure (lhs, rhs)
word w = sat ((w ==) . map toLower) >> pure w
identifier = map toLower <$> sat \w -> not $ elem w ["|", "[", "]"] || isSectName w
clause = (,)
<$> (asum (word <$> ((fst <$> dirTab) ++ [">", "moving", "stationary", "no"])) <|> pure "")
<*> identifier
rulegrp = (<* eof) $ patternRule <|> (:[]) . Rule Nothing . Cmd <$> identifier
patternRule = do
dirs <- asum (fmap ((:[]) . fromDir) . word <$> (fst <$> dirTab)) <|> pure (snd <$> dirTab)
pats <- some $ between (word "[") (word "]") (many clause `sepBy` word "|")
rhs <- word "->" *> (Sub . concat <$> some (between (word "[") (word "]") (many clause `sepBy` word "|")))
<|> Cmd <$> identifier
let
dirAgnostic [fcs] = all ((/= ">") . fst) fcs
dirAgnostic _ = False
dirs' = if all dirAgnostic pats then [1] else dirs
pure [Rule (Just (d, pats)) rhs | d <- dirs]
fromDir d = maybe (error "BUG!") id $ lookup d dirTab
dirTab =
[ ("up", zi)
, ("down", 0-zi)
, ("left", 0-1)
, ("right", 1)
]
parseRules = some $ (<* blankLines) $
either bad pure . parse rulegrp . words =<< anything
parseLevels = some $ some (map toLower <$> sat (not . null)) <* blankLines
-- String interning.
data PatVar = PatVar String Int [Int]
data Opt = Opt
{ _sprites :: [([String], [String])]
, _rules :: [[Rule PatVar]]
, _levels :: [((Int, Int), [(Zi, [Int])])]
, _playerIndexes :: [Int]
}
second f (x, y) = (x, f y)
nub xs = go xs [] where
go xs seen = case xs of
[] -> []
x : xt
| x `elem` seen -> go xt seen
| otherwise -> x : go xt (x : seen)
compile ast = do
leg <- reduceLegend (_objects ast) (_legend ast)
let
lvls = do
lvl <- _astLevels ast
let h = length lvl
let w = foldr1 max $ length <$> lvl
pure ((w, h), [(Zi c (h - r - 1), unlegend x) | (r, cols) <- zip [0..] $ map (zip [0..]) lvl, (c, x) <- dropWhile ((== ' ') . snd) cols])
unlegend ' ' = []
unlegend c = filter (/= 0) case lookup [c] leg of
Just (And ss) -> map objIdx ss
Just (Single s) -> [objIdx s]
_ -> error "bad level"
objIdx s = maybe (error "bad object") id $ lookup s $ zip objs [0..]
ruleVars = concatMap ruleVars' $ concat $ _astRules ast
ruleVars' (Rule m _) = case m of
Nothing -> []
Just (_, fcsss) -> map snd $ concat $ concat fcsss
vars fcss = map snd $ concat fcss
objs = nub $ (fst <$> _objects ast) ++ ruleVars
opt (Rule cond act) = Rule
(second (map $ map $ map toPatVar) <$> cond)
case act of
Sub subs -> Sub $ map (map toPatVar) subs
Cmd s -> Cmd s
toPatVar (f, c) = PatVar f (objIdx c) $ map objIdx cands
where
cpat = maybe (Single c) id $ lookup c leg
cands = case cpat of
Single s -> [s]
Or ss -> ss
pure $ Opt
(snd <$> _objects ast)
(map opt <$> _astRules ast)
lvls
[objIdx "player"]
reduceLegend objs leg = go (map (\(s, _) -> (s, Single s)) objs) leg
where
go acc [] = Right acc
go acc ((lhs, rhs):rest) = case rhs of
Single s -> case lookup s acc of
Just _ -> go ((lhs, rhs):acc) rest
Nothing -> Left $ "undefined " ++ s
Or ss -> do
sss <- mapM (\s -> case lookup s acc of
Just (Single s') -> Right [s']
Just (Or ss') -> Right ss'
_ -> Left $ "bad or term: " ++ s) ss
go ((lhs, Or $ concat sss):acc) rest
And ss -> do
ss' <- mapM (\s -> case lookup s acc of
Just (Single s') -> Right s'
_ -> Left $ "bad and term: " ++ s) ss
go ((lhs, And ss'):acc) rest
The web frontend code mostly coordinates calls between JavaScript and wasm, though there is some code involving drawing sprites.
[+] Show web frontend
#include "pre"
ffi "putchar" putChar :: Char -> IO ()
ffi "getchar" getChar :: IO Int
ffi "pixel" pixel :: Int -> Int -> Int -> Int -> IO ()
ffi "cheese" cheese :: IO ()
ffi "dim" dim :: Int -> Int -> IO ()
ffi "blit" blit :: Int -> Int -> Int -> IO ()
ffi "won" won :: IO ()
#include "zfc.hs"
colourIndex c = ord c - ord '0'
evil = unsafePerformIO $ newIORef undefined
export "levelup" levelUp
levelUp = do
(g, b) <- readIORef evil
let n' = (_level b + 1) `mod` (length $ _levels g)
render g $ loadLevel g n'
export "keydown" keydown
keydown :: Int -> IO ()
keydown = \case
37 -> travel (0-1)
38 -> travel zi
39 -> travel 1
40 -> travel (0-zi)
82 -> restart
90 -> undo
_ -> pure ()
travel z = do
(g, b) <- readIORef evil
let b' = step g z b
render g b'
when (_status b' == "won") won
export "restart" restart
restart = do
(g, b) <- readIORef evil
render g $ loadLevel g $ _level b
export "undo" undo
undo = do
(g, b) <- readIORef evil
render g $ oops b
sort [] = []
sort (x:xs) = sort (filter (<= x) xs) ++ [x] ++ sort (filter (> x) xs)
export "redraw" redraw
redraw = do
(g, b) <- readIORef evil
render g b
render g b = do
let (w, h) = _dim b
dim w h
writeIORef evil (g, b)
mapM_ id [blit k (re z) (h - 1 - im z) | (z, fcs) <- toAscList $ fst $ _hist b, k <- 0 : sort fcs]
export "play" play
play = do
scr <- lines <$> getContents
case parse script scr >>= compile of
Left e -> putStr "parse failed"
Right g -> do
mapM_ id [prep hues mat | (hues, mat) <- _sprites g]
let b = loadLevel g 0
render g b
export "click" click
click x y = do
(g, b) <- readIORef evil
let (w, h) = _dim b
case filter (\(z, cs) -> any (`elem` _playerIndexes g) cs) $ toAscList $ fst $ _hist b of
[] -> pure ()
(z, _):_ -> let
xd = x - re z
yd = (h - 1 - y) - im z
in case compare (xd*xd) (yd*yd) of
EQ -> pure ()
LT -> travel $ if 0 <= yd then zi else (0 - zi)
GT -> travel $ if 0 <= xd then 1 else (0 - 1)
prep hues mat = do
if null mat
then pixel 1 0 0 $ head cs
else mapM_ id [pixel n x y $ cs!!colourIndex c | (y, row) <- zip [0..] mat, (x, c) <- zip [0..] row, c /= '.']
cheese
where
cs = map (maybe (error "no such colour") id . (`lookup` rgb) . map toLower) hues
n = length mat
-- PWG 5101.1.
rgb =
[ ("lightgreen", 0x90ee90)
, ("green", 0x008000)
, ("darkblue", 0x8b)
, ("brown", 0xa52a2a)
, ("darkbrown", 0x5c4033)
, ("black", 0)
, ("orange", 0xffa500)
, ("white", 0xffffff)
, ("blue", 0x0000ff)
, ("yellow", 0xffff00)
, ("grey", 0xbebebe)
, ("gray", 0xbebebe)
, ("darkgray", 0x404040)
, ("darkgrey", 0x404040)
, ("purple", 0xa020f0)
, ("pink", 0xffc0cb)
, ("red", 0xff0000)
]
Ben Lynn blynn@cs.stanford.edu 💡