mirrors/lqml
1
Fork 0
mirror of https://gitlab.com/eql/lqml.git synced 2025-12-06 02:30:38 -08:00
Code Issues Projects Releases Packages Wiki Activity

add example 'sokoban'

Browse source
This commit is contained in:
pls.153 2022-03-30 00:53:54 +02:00
parent a5b827bc96
commit b897d60539
33 changed files with 5368 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

2
examples/sokoban/.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
*
!.gitignore

8
examples/sokoban/app.asd Normal file
View file

@ -0,0 +1,8 @@
(defsystem :app
:serial t
:depends-on ()
:components ((:file "lisp/3rd-party/sokoban")
(:file "lisp/3rd-party/my-levels")
(:file "lisp/package")
(:file "lisp/ui-vars")
(:file "lisp/sokoban")))

6
examples/sokoban/lisp/3rd-party/CONTRIBUTORS vendored Normal file
View file

@ -0,0 +1,6 @@
# Please add yourself to this file when you submit a patch.
Julian Fondren <ayrnieu@gmail.com>
- Maintainer.
- Contributed simple-ui ! :D
- also: raw-ui , cl-sokoban.el

3
examples/sokoban/lisp/3rd-party/COPYING vendored Normal file
View file

@ -0,0 +1,3 @@
BSD with no advertisement clause.
Copyrights held by their respective authors.

3
examples/sokoban/lisp/3rd-party/README.txt vendored Normal file
View file

@ -0,0 +1,3 @@
Please see http://www.cliki.net/CL-Sokoban for the original game.
See also note in "my-levels.lisp" (taken from "YASC_1_639_src.zip" on sourceforge.net).

816
examples/sokoban/lisp/3rd-party/levels.lisp vendored Normal file
View file

@ -0,0 +1,816 @@
(in-package :cl-sokoban)
(defmaze
" ##### "
" # # "
" #$ # "
" ### $## "
" # $ $ # "
"### # ## # ######"
"# # ## ##### ..#"
"# $ $ ..#"
"##### ### #@## ..#"
" # #########"
" ####### ")
(defmaze
"############ "
"#.. # ###"
"#.. # $ $ #"
"#.. #$#### #"
"#.. @ ## #"
"#.. # # $ ##"
"###### ##$ $ #"
" # $ $ $ $ #"
" # # #"
" ############")
(defmaze
" ######## "
" # @# "
" # $#$ ## "
" # $ $# "
" ##$ $ # "
"######### $ # ###"
"#.... ## $ $ #"
"##... $ $ #"
"#.... ##########"
"######## ")
(defmaze
" ########"
" # ....#"
"############ ....#"
"# # $ $ ....#"
"# $$$#$ $ # ....#"
"# $ $ # ....#"
"# $$ #$ $ $########"
"# $ # # "
"## ######### "
"# # ## "
"# $ ## "
"# $$#$$ @# "
"# # ## "
"########### ")
(defmaze
" ##### "
" # #####"
" # #$## #"
" # $ #"
"######### ### #"
"#.... ## $ $###"
"#.... $ $$ ## "
"#.... ##$ $ @# "
"######### $ ## "
" # $ $ # "
" ### ## # "
" # # "
" ###### ")
(defmaze
"###### ### "
"#.. # ##@##"
"#.. ### #"
"#.. $$ #"
"#.. # # $ #"
"#..### # $ #"
"#### $ #$ #"
" # $# $ #"
" # $ $ #"
" # ## #"
" #########")
(defmaze
" ##### "
" ####### ##"
"## # @## $$ #"
"# $ #"
"# $ ### #"
"### #####$###"
"# $ ### ..# "
"# $ $ $ ...# "
"# ###...# "
"# $$ # #...# "
"# ### ##### "
"#### ")
(defmaze
" #### "
" # ###########"
" # $ $ $ #"
" # $# $ # $ #"
" # $ $ # #"
"### $# # #### #"
"#@#$ $ $ ## #"
"# $ #$# # #"
"# $ $ $ $ #"
"##### #########"
" # # "
" # # "
" #......# "
" #......# "
" #......# "
" ######## ")
(defmaze
" #######"
" # ...#"
" ##### ...#"
" # . .#"
" # ## ...#"
" ## ## ...#"
" ### ########"
" # $$$ ## "
" ##### $ $ #####"
"## #$ $ # #"
"#@ $ $ $ $ #"
"###### $$ $ #####"
" # # "
" ######## ")
(defmaze
" ### #############"
"##@#### # #"
"# $$ $$ $ $ ...#"
"# $$$# $ #...#"
"# $ # $$ $$ #...#"
"### # $ #...#"
"# # $ $ $ #...#"
"# ###### ###...#"
"## # # $ $ #...#"
"# ## # $$ $ $##..#"
"# ..# # $ #.#"
"# ..# # $$$ $$$ #.#"
"##### # # #.#"
" # ######### #.#"
" # #.#"
" ###############")
(defmaze
" #### "
" #### # # "
" ### @###$ # "
" ## $ # "
" ## $ $$## ## "
" # #$## # "
" # # $ $$ # ### "
" # $ # # $ #####"
"#### # $$ # #"
"#### ## $ #"
"#. ### ########"
"#.. ..# #### "
"#...#.# "
"#.....# "
"####### ")
(defmaze
"################ "
"# # "
"# # ###### # "
"# # $ $ $ $# # "
"# # $@$ ## ##"
"# # $ $ $###...#"
"# # $ $ ##...#"
"# ###$$$ $ ##...#"
"# # ## ##...#"
"##### ## ##...#"
" ##### ###"
" # # "
" ####### ")
(defmaze
" ######### "
" ## ## ###### "
"### # # ###"
"# $ #$ # # ... #"
"# # $#@$## # #.#. #"
"# # #$ # . . #"
"# $ $ # # #.#. #"
"# ## ##$ $ . . #"
"# $ # # #$#.#. #"
"## $ $ $ $... #"
" #$ ###### ## #"
" # # ##########"
" #### ")
(defmaze
" ####### "
" ####### # "
" # # $@$ # "
" #$$ # #########"
" # ###......## #"
" # $......## # #"
" # ###...... #"
"## #### ### #$##"
"# #$ # $ # # "
"# $ $$$ # $## # "
"# $ $ ###$$ # # "
"##### $ # # "
" ### ### # # "
" # # # "
" ######## # "
" #### ")
(defmaze
" ######## "
" # # # "
" # $ # "
" ### #$ #### "
" # $ ##$ # "
" # # @ $ # $# "
" # # $ ####"
" ## ####$## #"
" # $#.....# # #"
" # $..*$. $# ###"
"## #.....# # "
"# ### ####### "
"# $$ # # "
"# # # "
"###### # "
" ##### ")
(defmaze
"##### "
"# ## "
"# # #### "
"# $ #### # "
"# $$ $ $# "
"###@ #$ ## "
" # ## $ $ ##"
" # $ ## ## .#"
" # #$##$ #.#"
" ### $..##.#"
" # #.*...#"
" # $$ #.....#"
" # #########"
" # # "
" #### ")
(defmaze
" ########## "
" #.. # # "
" #.. # "
" #.. # #### "
" ####### # ##"
" # #"
" # # ## # #"
"#### ## #### ##"
"# $ ##### # #"
"# # $ $ # $ #"
"# @$ $ # ##"
"#### ## ####### "
" # # "
" ###### ")
(defmaze
" ########### "
" # . # # "
" # #. @ # "
" ##### ##..# #### "
"## # ..### ###"
"# $ #... $ # $ #"
"# .. ## ## ## #"
"####$##$# $ # # #"
" ## # #$ $$ # #"
" # $ # # # $## #"
" # #"
" # ########### #"
" #### ####")
(defmaze
" ###### "
" # @#### "
"##### $ # "
"# ## #### "
"# $ # ## # "
"# $ # ##### # "
"## $ $ # # "
"## $ $ ### # # "
"## # $ # # # "
"## # #$# # # "
"## ### # # ######"
"# $ #### # #....#"
"# $ $ ..#.#"
"####$ $# $ ....#"
"# # ## ....#"
"###################")
(defmaze
" ########## "
"##### #### "
"# # $ #@ # "
"# #######$#### ###"
"# # ## # #$ ..#"
"# # $ # # #.#"
"# # $ # #$ ..#"
"# # ### ## #.#"
"# ### # # #$ ..#"
"# # # #### #.#"
"# #$ $ $ #$ ..#"
"# $ # $ $ # #.#"
"#### $### #$ ..#"
" # $$ ###....#"
" # ## ######"
" ######## ")
(defmaze
"######### "
"# # "
"# #### "
"## #### # # "
"## #@## # "
"# $$$ $ $$# "
"# # ## $ # "
"# # ## $ ####"
"#### $$$ $# #"
" # ## ....#"
" # # # #.. .#"
" # # # ##...#"
" ##### $ #...#"
" ## #####"
" ##### ")
(defmaze
"###### #### "
"# ####### #####"
"# $# # $ # #"
"# $ $ $ # $ $ #"
"##$ $ # @# $ #"
"# $ ########### ##"
"# # #.......# $# "
"# ## # ......# # "
"# # $........$ # "
"# # $ #.... ..# # "
"# $ $####$#### $# "
"# $ ### $ $ ##"
"# $ $ $ $ #"
"## ###### $ ##### #"
"# # #"
"###################")
(defmaze
" ####### "
" # # #### "
"##### $#$ # ## "
"#.. # # # # "
"#.. # $#$ # $#### "
"#. # #$ # # "
"#.. $# # $ # "
"#..@# #$ #$ # # "
"#.. # $# $# # "
"#.. # #$$#$ # ##"
"#.. # $# # $#$ #"
"#.. # # # # #"
"##. #### ##### #"
" #### #### #####")
(defmaze
"############### "
"#.......... .#### "
"#..........$$.# # "
"###########$ # ##"
"# $ $ $ #"
"## #### # $ # #"
"# # ## # ##"
"# $# # ## ### ##"
"# $ #$### ### ##"
"### $ # # ### ##"
"### $ ## # # ##"
" # $ # $ $ $ #"
" # $ $#$$$ # #"
" # # $ #####"
" # @## # # # "
" ############## ")
(defmaze
"#### "
"# ############## "
"# # ..#......# "
"# # # ##### ...# "
"##$# ........# "
"# ##$###### ####"
"# $ # ######@ #"
"##$ # $ ###### #"
"# $ #$$$## #"
"# # #$#$###"
"# #### #$$$$$ # "
"# # $ # # "
"# # ## ###"
"# ######$###### $ #"
"# # # #"
"########## #####")
(defmaze
" ####### "
" # # ##### "
"## # #...### "
"# $# #... # "
"# $ #$$ ... # "
"# $# #... .# "
"# # $########"
"##$ $ $ #"
"## # $$ # #"
" ###### ##$$@#"
" # ##"
" ######## ")
(defmaze
" ################# "
" #... # # ##"
"##..... $## # #$ #"
"#......# $ # #"
"#......# # # # #"
"######### $ $ $ #"
" # #$##$ ##$##"
" ## $ # $ #"
" # ## ### # ##$ #"
" # $ $$ $ $ #"
" # $ $##$ ######"
" ####### @ ## "
" ###### ")
(defmaze
" ##### "
" ##### # "
" ## $ $ ####"
"##### $ $ $ ##.#"
"# $$ ##..#"
"# ###### ###.. #"
"## # # #... #"
"# $ # #... #"
"#@ #$ ## ####...#"
"#### $ $$ ##..#"
" ## $ $ $...#"
" # $$ $ # .#"
" # $ $ ####"
" ###### # "
" ##### ")
(defmaze
"##### "
"# ## "
"# $ ######### "
"## # # ######"
"## # $#$#@ # #"
"# # $ # $ #"
"# ### ######### ##"
"# ## ..*..... # ##"
"## ## *.$..$.$ # ##"
"# $########## ##$ #"
"# $ $ $ $ #"
"# # # # # #"
"###################")
(defmaze
" ########### "
" # # # "
"##### # $ $ # "
"# ##### $## # ## "
"# $ ## # ## $ # "
"# $ @$$ # ##$$$ # "
"## ### # ## # "
"## # ### #####$# "
"## # $ #....# "
"# ### ## $ #....##"
"# $ $ # #..$. #"
"# ## $ # ##.... #"
"##### ######...##"
" ##### ##### ")
(defmaze
" #### "
" # ######### "
" ## ## # # "
" # $# $@$ #### "
" #$ $ # $ $# ##"
"## $## #$ $ #"
"# # # # $$$ #"
"# $ $ $## ####"
"# $ $ #$# # # "
"## ### ###$ # "
" # #.... # "
" ####......#### "
" #....#### "
" #...## "
" #...# "
" ##### ")
(defmaze
" #### "
" ##### # "
" ## $# "
"## $ ## ### "
"#@$ $ # $ # "
"#### ## $# "
" #....#$ $ # "
" #....# $# "
" #.... $$ ##"
" #... # $ #"
" ######$ $ #"
" # ###"
" #$ ### "
" # # "
" #### ")
(defmaze
"############"
"## ## #"
"## $ $ #"
"#### ## $$ #"
"# $ # #"
"# $$$ # ####"
"# # # $ ##"
"# # # $ #"
"# $# $# #"
"# ..# ####"
"####.. $ #@#"
"#.....# $# #"
"##....# $ #"
"###..## #"
"############")
(defmaze
" ######### "
" #.... ## "
" #.#.# $ ## "
"##....# # @## "
"# ....# # ##"
"# #$ ##$ #"
"## ### $ #"
" #$ $ $ $# #"
" # # $ $ ## #"
" # ### ## #"
" # ## ## ##"
" # $ # $ # "
" ###$ $ ### "
" # ##### "
" #### ")
(defmaze
"############ ######"
"# # # ###....#"
"# $$# @ .....#"
"# # ### # ....#"
"## ## ### # ....#"
" # $ $ # # ####"
" # $ $## # #"
"#### # #### # ## #"
"# # #$ ## # #"
"# $ $ # ## # ##"
"# # $ $ # # # "
"# $ ## ## # ##### "
"# $$ $$ # "
"## ## ### $ # "
" # # # # "
" ###### ###### ")
(defmaze
" ##### "
"##### ###### # "
"# #### $ $ $ # "
"# $ ## ## ## ## "
"# $ $ $ $ # "
"### $ ## ## ##"
" # ##### #####$$ #"
" ##$##### @## #"
" # $ ###$### $ ##"
" # $ # ### ### "
" # $$ $ # $$ # "
" # # ## # "
" #######.. .### "
" #.........# "
" #.........# "
" ########### ")
(defmaze
"########### "
"#...... #########"
"#...... # ## #"
"#..### $ $ #"
"#... $ $ # ## #"
"#...#$##### # #"
"### # #$ #$ #"
" # $$ $ $ $## #"
" # $ #$#$ ##$ #"
" ### ## # ## #"
" # $ $ ## ######"
" # $ $ # "
" ## # # # "
" #####@##### "
" ### ")
(defmaze
" #### "
"####### @# "
"# $ # "
"# $## $# "
"##$#...# # "
" # $... # "
" # #. .# ##"
" # # #$ #"
" #$ $ #"
" # #######"
" #### ")
(defmaze
" ######"
" #############....#"
"## ## ##....#"
"# $$## $ @##....#"
"# $$ $# ....#"
"# $ ## $$ # # ...#"
"# $ ## $ # ....#"
"## ##### ### ##.###"
"## $ $ ## . #"
"# $### # ##### ###"
"# $ # # "
"# $ #$ $ $### # "
"# $$$# $ # #### "
"# # $$ # "
"###### ### "
" ##### ")
(defmaze
" ############ "
" # ##"
" # # #$$ $ #"
" #$ #$# ## @#"
" ## ## # $ # ##"
" # $ #$ # # "
" # # $ # # "
" ## $ $ ## # "
" # # ## $ # "
" # ## $$# # "
"######$$ # # "
"#....# ######## "
"#.#... ## "
"#.... # "
"#.... # "
"######### ")
(defmaze
" ##### "
" ## ## "
" ## # "
" ## $$ # "
" ## $$ $ # "
" # $ $ # "
"#### # $$ #####"
"# ######## ## #"
"#. $$$@#"
"#.# ####### ## ##"
"#.# #######. #$ $##"
"#........... # #"
"############## $ #"
" ## ##"
" #### ")
(defmaze
" ######## "
" #### ######"
" # ## $ $ @#"
" # ## ##$#$ $ $##"
"### ......# $$ ##"
"# ......# # #"
"# # ......#$ $ #"
"# #$...... $$# $ #"
"# ### ###$ $ ##"
"### $ $ $ $ # "
" # $ $ $ $ # "
" ###### ###### "
" ##### ")
(defmaze
" ####### "
" ##### # #### "
" # # $ # "
" #### #$$ ## ## # "
"## # # ## ###"
"# ### $#$ $ $ #"
"#... # ## # #"
"#...# @ # ### ##"
"#...# ### $ $ #"
"######## ## # #"
" #########")
(defmaze
" ##### "
" # # "
" # # ####### "
" # $@###### "
" # $ ##$ ### # "
" # #### $ $ # "
" # ##### # #$ ####"
"## #### ##$ #"
"# $# $ # ## ## #"
"# # #...# #"
"###### ### ... #"
" #### # #...# #"
" # ### # #"
" # #"
" #########")
(defmaze
"##### #### "
"#...# # #### "
"#...### $ # "
"#....## $ $### "
"##....## $ # "
"###... ## $ $ # "
"# ## # $ # "
"# ## # ### ####"
"# $ # #$ $ #"
"# $ @ $ $ #"
"# # $ $$ $ ###"
"# ###### ### "
"# ## #### "
"### ")
(defmaze
"########## "
"# #### "
"# ###### # ##"
"# # $ $ $ $ #"
"# #$ #"
"###$ $$# ###"
" # ## # $## "
" ##$# $ @# "
" # $ $ ### "
" # # $ # "
" # ## # # "
" ## ##### # "
" # # "
" #.......### "
" #.......# "
" ######### ")
(defmaze
" #### "
" ######### ## "
"## $ $ #####"
"# ## ## ##...#"
"# #$$ $ $$#$##...#"
"# # @ # ...#"
"# $# ###$$ ...#"
"# $ $$ $ ##....#"
"###$ #######"
" # ####### "
" #### ")
(defmaze
" ######### "
" #*.$#$.$# "
" #.*.$.$.# "
" #*.$.$.$# "
" #.*.$.$.# "
" #*.$.$.$# "
" ### ### "
" # # "
"###### ######"
"# #"
"# $ $ $ $ $ #"
"## $ $ $ $ ##"
" #$ $ $ $ $# "
" # $@$ # "
" # ##### # "
" #### #### ")
(defmaze
" #### "
" # ## "
" # ## "
" # $$ ## "
" ###$ $ ## "
" #### $ # "
"### # ##### # "
"# # #....$ # "
"# # $ ....# # "
"# $ # #.*..# # "
"### #### ### # "
" #### @$ ##$##"
" ### $ #"
" # ## #"
" #########")
(defmaze
" ############ "
" ##.. # # "
" ##..* $ $ # "
" ##..*.# # # $## "
" #..*.# # # $ # "
"####...# # # # "
"# ## # # "
"# @$ $ ### # ## "
"# $ $ # # # "
"###$$ # # # # # "
" # $ # # #####"
" # $# ##### #"
" #$ # # # #"
" # ### ## #"
" # # # ##"
" #### ###### ")
(setf *mazes* (nreverse *mazes*))

3725
examples/sokoban/lisp/3rd-party/my-levels.lisp vendored Normal file
View file

File diff suppressed because it is too large Load diff

130
examples/sokoban/lisp/3rd-party/sokoban.lisp vendored Normal file
View file

@ -0,0 +1,130 @@
(defpackage :cl-sokoban
(:nicknames :sokoban)
(:use :cl)
(:export
#:*mazes*
#:*move-hook*
#:*rules*
#:*solutions*
#:*undo-hook*
#:copy-maze
#:defmaze
#:maze
#:maze-dimensions
#:maze-player
#:maze-text
#:move
#:simple-ui
#:undo))
(in-package :cl-sokoban)
(defvar *mazes* nil
"A list of two-dimensional character arrays, describing Sokoban puzzles.")
(defvar *move-hook* nil)
(defvar *solutions* nil)
(defvar *rules*
'(("@ " " @")
("@." " &")
("& " ".@")
("&." ".&")
("@$ " " @$")
("@$." " @*")
("&$ " ".@$")
("&$." ".@*")
("@* " " &$")
("@*." " &*")
("&* " ".&$")
("&*." ".&*"))
"A list of textual transformation rules that the cl-sokoban mover steps
through. A rule has the format (\"from\" \" to \"); when \"from\" matches
the maze, \" to \" replaces it in the maze.")
(defstruct (maze :named (:type vector) (:copier nil))
player
dimensions
text)
(defun copy-maze (maze)
(make-maze :player (maze-player maze)
:dimensions (maze-dimensions maze)
:text (mapcar #'copy-seq (maze-text maze))))
(defun simple-ui ()
(do ((input "" (read-line)))
((search "q" input))
(cond ((search "n" input) (move :north (first *mazes*)))
((search "e" input) (move :east (first *mazes*)))
((search "w" input) (move :west (first *mazes*)))
((search "s" input) (move :south (first *mazes*))))
(format t "~{~&~A~%~}" (maze-text (first *mazes*)))))
(defun find-player (rows)
(loop :for y :from 0
:for row :in rows
:for x? = (or (position #\@ row)
(position #\& row))
:when x? return (cons x? y)
:finally (error "Maze lacks a player (@): ~S" rows)))
(defun move (direction maze)
(loop :for (from to) :in *rules*
:when (string= from (lookahead (length from) direction maze))
:do (return (setahead to direction maze))))
(defun move-point (location direction)
(case direction
(:east (cons (1+ (car location)) (cdr location)))
(:west (cons (1- (car location)) (cdr location)))
(:north (cons (car location) (1- (cdr location))))
(:south (cons (car location) (1+ (cdr location))))))
(defun off-maze-p (location maze)
(destructuring-bind (x . y) (maze-dimensions maze)
(or (>= (car location) x)
(>= (cdr location) y)
(< (car location) 0)
(< (cdr location) 0))))
(defun lookahead (distance direction maze)
(do ((location (maze-player maze) (move-point location direction))
(index 0 (1+ index))
(chars nil (cons (elt (elt (maze-text maze) (cdr location))
(car location))
chars)))
((or (= index distance)
(off-maze-p location maze))
(coerce (reverse chars) 'string))))
(defun undo (maze steps)
(dolist (step steps)
(let* ((location (first step))
(char (second step))
(row (elt (maze-text maze) (cdr location))))
(setf (elt row (car location)) char)))
(setf (maze-player maze) (find-player (maze-text maze))))
(defun setahead (string direction maze)
(let (undo-steps)
(loop :for char :across string
:for location = (maze-player maze)
:then (prog1
(move-point location direction)
(when *move-hook*
(funcall *move-hook* char location direction)))
:do (let ((row (elt (maze-text maze) (cdr location))))
(when *undo-hook*
(push (list location (elt row (car location)))
undo-steps))
(setf (elt row (car location)) char)))
(when *undo-hook*
(funcall *undo-hook* undo-steps)))
(setf (maze-player maze) (find-player (maze-text maze))))
(defun defmaze (&rest rows)
(push (make-maze :text rows
:dimensions (cons (length (first rows))
(length rows))
:player (find-player rows))
*mazes*))

5
examples/sokoban/lisp/package.lisp Normal file
View file

@ -0,0 +1,5 @@
(defpackage :qsoko
(:use :cl :qml)
(:export
#:change-level
#:start))

8
examples/sokoban/lisp/qml-reload/on-reloaded.lisp Normal file
View file

@ -0,0 +1,8 @@
;;; this file will be loaded every time QML has been reloaded
(in-package :qsoko)
(progn
(let ((*no-delete* t))
(set-maze))
(q> |to| ui:*level* (1- (length *my-mazes*))))

268
examples/sokoban/lisp/sokoban.lisp Normal file
View file

@ -0,0 +1,268 @@
;;;
;;; QML UI for CL-Sokoban, see http://www.cliki.net/CL-Sokoban
;;;
(in-package :qsoko)
(defvar *item-types*
'((#\# . :wall)
(#\$ . :object)
(#\* . :object2)
(#\. . :goal)
(#\@ . :player)
(#\& . :player2)))
(defvar *items* nil)
(defvar *item-size* nil)
(defvar *maze* nil)
(defvar *my-mazes* (mapcar 'sokoban:copy-maze sokoban:*mazes*))
(defvar *solving* nil)
(defvar *undo-stack* nil)
(defvar *level-changed* nil)
(defun level ()
(floor (q< |value| ui:*level*)))
(defun set-level (index)
(q> |value| ui:*level* index))
(defun assoc* (item alist)
(cdr (assoc item alist)))
(defun char-type (char)
(cdr (assoc char *item-types*)))
(defun type-char (type)
(car (find type *item-types* :key 'cdr)))
(defun set-maze ()
(setf *maze* (nth (level) *my-mazes*))
(update-translate-xy)
(create-items)
(place-all-items)
(setf *undo-stack* nil))
(defun reset-maze ()
(setf *maze* (setf (nth (level) *my-mazes*)
(sokoban:copy-maze (nth (level) sokoban:*mazes*))))
(update-placed-items t)
(setf *undo-stack* nil))
(defvar *translate-x* 0)
(defvar *translate-y* 0)
(defun find-file (file)
(x:if-it (probe-file file)
(format nil "file://~A" x:it)
(x:cc "qrc:/" file)))
(defun update-translate-xy ()
"Set x and y translation for maze centering."
(let ((dim (sokoban:maze-dimensions *maze*))
(img-px 32)
(board-size 16))
(setf *translate-x* (floor (/ (* img-px (- board-size (car dim))) 2))
*translate-y* (floor (/ (* img-px (- board-size (cdr dim))) 2)))))
(defun create-item (type)
(let* ((name (string-downcase type))
(item (qjs |makeItem| ui:*dynamic* name)))
(q> |source| item
(find-file (format nil "qml/img/~A.png" name)))
(q> |objectName| item name)
(unless *item-size*
(setf *item-size* (q< |sourceSize| item)))
item))
(defun create-items ()
(clear-items)
(flet ((add (types)
(dolist (type (x:ensure-list types))
(let ((item (create-item type)))
(push item (cdr (assoc type *items*)))
;; add to QObject hirarchy, for 'objectName' to be findable
(qset item |parent|
(find-quick-item ui:*board*))))))
(dolist (row (sokoban:maze-text *maze*))
(x:do-string (char row)
(unless (char= #\Space char)
(let ((type (char-type char)))
(cond ((find type '(:player :player2))
(add '(:player :player2)))
((find type '(:object :object2))
(add '(:object :object2 :goal)))
((eql :wall type)
(add :wall)))))))))
(defvar *no-delete* nil)
(defun clear-items ()
(unless *no-delete*
(dolist (items *items*)
(dolist (item (rest items))
(q! |destroy| item))))
(setf *items* (mapcar (lambda (x) (list (cdr x))) *item-types*)))
(defvar *running-animations* 0)
(defvar *function-queue* nil)
(defun animation-change (running) ; called from QML
(incf *running-animations* (if running 1 -1))
(x:while (and (zerop *running-animations*)
*function-queue*)
(funcall (pop *function-queue*))))
(defun run-or-enqueue (function)
(if (zerop *running-animations*)
(funcall function)
(setf *function-queue* (nconc *function-queue* (list function)))))
(defmacro queued (&rest functions)
"Run passed functions in order, waiting for currently running (or newly
triggered) animations to finish first."
`(progn
,@(mapcar (lambda (fun) `(run-or-enqueue (lambda () ,fun)))
functions)))
(defun change-level (direction/index)
"Changes *LEVEL* in given direction or to index."
(let ((level (min (1- (length *my-mazes*))
(max 0 (if (numberp direction/index)
direction/index
(+ (if (eql :next direction/index) 1 -1)
(level)))))))
(when (/= level (level))
(queued (q> |running| ui:*zoom-board-out* t)
(set-level level) ; will call SET-MAZE from QML
(q> |running| ui:*zoom-board-in* t))))
(setf *level-changed* t)
(level))
(defun solve ()
(setf *level-changed* nil)
(let ((*solving* t))
(reset-maze)
(x:do-string (ch (nth (level) sokoban:*solutions*))
(when *level-changed*
(setf *level-changed nil)
(return-from solve))
(sokoban:move (case (char-downcase ch)
(#\u :north)
(#\d :south)
(#\l :west)
(#\r :east))
*maze*)
(x:while (plusp *running-animations*)
(qsleep 0.05)))))
(defun set-x (item x &optional animate)
(let ((x* (+ x *translate-x*)))
(if animate
(q> |x| item x*)
(qset item |x| x*))))
(defun set-y (item y &optional animate)
(let ((y* (+ y *translate-y*)))
(if animate
(q> |y| item y*)
(qset item |y| y*))))
(defun child-at (x y)
(q! |childAt| ui:*board*
(+ x *translate-x*)
(+ y *translate-y*)))
(defun place-items (type &optional reset)
(let ((char (type-char type))
(items (assoc* type *items*))
(y 0))
(unless (eql :wall type)
(dolist (item items)
(q> |visible| item nil)))
(dolist (row (sokoban:maze-text *maze*))
(let ((x 0))
(x:do-string (curr-char row)
(when (char= char curr-char)
(let ((item (first items)))
(set-x item x)
(set-y item y)
(q> |visible| item t))
(setf items (rest items)))
(incf x (first *item-size*))))
(incf y (second *item-size*)))))
(defun place-all-items ()
(dolist (type '(:wall :goal :object2 :player2 :player :object))
(place-items type)))
(defun update-placed-items (&optional reset)
(dolist (type '(:goal :object2 :player2 :player :object))
(place-items type reset)))
(let (ex ex-ex)
(defun move-item (char pos direction) ; see sokoban:*move-hook*
(let* ((type (char-type char))
(pos-x (car pos))
(pos-y (cdr pos))
(w (first *item-size*))
(h (second *item-size*))
(x (* w pos-x))
(y (* h pos-y))
(dx (case direction (:east w) (:west (- w)) (t 0)))
(dy (case direction (:south h) (:north (- h)) (t 0)))
(item (child-at (+ x (/ w 2)) (+ y (/ h 2)))))
(unless (qnull item)
(if (zerop dy)
(set-x item (+ x dx) 'animate)
(set-y item (+ y dy) 'animate))
(dolist (tp (list type ex ex-ex))
(when (find tp '(:player2 :object2 :goal))
(queued (update-placed-items))
(return)))
(shiftf ex-ex ex type)
(when (eql :player type)
(qlater (lambda () (when (game-finished)
(final-animation)))))))))
(defun add-undo-step (step)
(push step *undo-stack*))
(defun undo ()
(when *undo-stack*
(sokoban:undo *maze* (pop *undo-stack*))
(update-placed-items)))
(defun game-finished ()
;; finished: no more :object, only :object2
(let ((ch (type-char :object)))
(dolist (str (sokoban:maze-text *maze*))
(when (find ch str)
(return-from game-finished))))
t)
(defun final-animation ()
(queued (q> |running| ui:*rotate-player* t)
(q>* |running| ui:*wiggle-box* t)))
(defun button-pressed () ; called from QML
(let ((button (intern (string-upcase (q< |objectName| *caller*))
:keyword)))
(case button
(:up (sokoban:move :north *maze*))
(:down (sokoban:move :south *maze*))
(:left (sokoban:move :west *maze*))
(:right (sokoban:move :east *maze*))
(:previous (change-level :previous))
(:next (change-level :next))
(:undo (undo))
(:restart (reset-maze))
(:solve (qlater 'solve)))) ; QLATER: prevent timer problem
(values)) ; no return value to QML
(defun start ()
(setf sokoban:*move-hook* 'move-item
sokoban:*undo-hook* 'add-undo-step)
(q> |to| ui:*level* (1- (length *my-mazes*)))
(set-maze))
(qlater 'start)

42
examples/sokoban/lisp/ui-vars.lisp Normal file
View file

@ -0,0 +1,42 @@
(defpackage ui
(:use :cl :qml)
(:export
#:*board*
#:*buttons1*
#:*buttons2*
#:*down*
#:*dynamic*
#:*left*
#:*level*
#:*next*
#:*previous*
#:*restart*
#:*right*
#:*rotate-player*
#:*solve*
#:*undo*
#:*up*
#:*wiggle-box*
#:*zoom-board-in*
#:*zoom-board-out*))
(in-package :ui)
(defparameter *board* "board")
(defparameter *buttons1* "buttons1")
(defparameter *buttons2* "buttons2")
(defparameter *down* "down")
(defparameter *dynamic* "dynamic")
(defparameter *left* "left")
(defparameter *level* "level")
(defparameter *next* "next")
(defparameter *previous* "previous")
(defparameter *restart* "restart")
(defparameter *right* "right")
(defparameter *rotate-player* "rotate_player")
(defparameter *solve* "solve")
(defparameter *undo* "undo")
(defparameter *up* "up")
(defparameter *wiggle-box* "wiggle_box")
(defparameter *zoom-board-in* "zoom_board_in")
(defparameter *zoom-board-out* "zoom_board_out")

15
examples/sokoban/qml/ext/ArrowButton.qml Normal file
View file

@ -0,0 +1,15 @@
import QtQuick 2.15
import QtQuick.Controls 2.15
Button {
width: main.small ? 37 : 50
height: width
flat: true
focusPolicy: Qt.NoFocus
font.family: fontAwesome.name
font.pixelSize: 1.2 * width
opacity: 0.2
scale: 1.2
onPressed: Lisp.call(this, "qsoko:button-pressed")
}

12
examples/sokoban/qml/ext/Button.qml Normal file
View file

@ -0,0 +1,12 @@
import QtQuick 2.15
import QtQuick.Controls 2.15
Button {
width: main.small ? 32 : 50
height: width
font.family: fontAwesome.name
font.pixelSize: width - 6
opacity: 0.8
onPressed: Lisp.call(this, "qsoko:button-pressed")
}

21
examples/sokoban/qml/ext/Dynamic.qml Normal file
View file

@ -0,0 +1,21 @@
import QtQuick 2.15
Item {
objectName: "dynamic"
property Component box: Qt.createComponent("dynamic/Box.qml")
property Component box2: Qt.createComponent("dynamic/Box2.qml")
property Component player: Qt.createComponent("dynamic/Player.qml")
property Component fixed: Qt.createComponent("dynamic/Fixed.qml")
function makeItem(name) {
switch (name) {
case "object": return box.createObject()
case "object2": return box2.createObject()
case "player":
case "player2": return player.createObject()
case "wall":
case "goal": return fixed.createObject()
}
}
}

6
examples/sokoban/qml/ext/NumberAnimation.qml Normal file
View file

@ -0,0 +1,6 @@
import QtQuick 2.15
NumberAnimation {
onRunningChanged: Lisp.call("qsoko:animation-change", running)
}

6
examples/sokoban/qml/ext/RotationAnimation.qml Normal file
View file

@ -0,0 +1,6 @@
import QtQuick 2.15
RotationAnimation {
onRunningChanged: Lisp.call("qsoko:animation-change", running)
}

5
examples/sokoban/qml/ext/ScaleAnimator.qml Normal file
View file

@ -0,0 +1,5 @@
import QtQuick 2.15
ScaleAnimator {
onRunningChanged: Lisp.call("qsoko:animation-change", running)
}

6
examples/sokoban/qml/ext/SequentialAnimation.qml Normal file
View file

@ -0,0 +1,6 @@
import QtQuick 2.15
SequentialAnimation {
onRunningChanged: Lisp.call("qsoko:animation-change", running)
}

18
examples/sokoban/qml/ext/dynamic/Box.qml Normal file
View file

@ -0,0 +1,18 @@
import QtQuick 2.15
import "../" as Ext
Image {
Behavior on x {
Ext.NumberAnimation {
duration: 150
easing.type: Easing.InQuart
}
}
Behavior on y {
Ext.NumberAnimation {
duration: 150
easing.type: Easing.InQuart
}
}
}

48
examples/sokoban/qml/ext/dynamic/Box2.qml Normal file
View file

@ -0,0 +1,48 @@
import QtQuick 2.15
import "../" as Ext
Image {
id: box2
Behavior on x {
Ext.NumberAnimation {
duration: 150
easing.type: Easing.InQuart
}
}
Behavior on y {
Ext.NumberAnimation {
duration: 150
easing.type: Easing.InQuart
}
}
// final animation
Ext.SequentialAnimation {
objectName: "wiggle_box"
loops: 3
RotationAnimation {
target: box2
property: "rotation"
from: 0; to: 30
duration: 150
}
RotationAnimation {
target: box2
property: "rotation"
from: 30; to: -30
duration: 300
}
RotationAnimation {
target: box2
property: "rotation"
from: -30; to: 0
duration: 150
}
}
}

4
examples/sokoban/qml/ext/dynamic/Fixed.qml Normal file
View file

@ -0,0 +1,4 @@
import QtQuick 2.15
Image {
}

30
examples/sokoban/qml/ext/dynamic/Player.qml Normal file
View file

@ -0,0 +1,30 @@
import QtQuick 2.15
import "../" as Ext
Image {
id: player
Behavior on x {
Ext.NumberAnimation {
duration: 120
easing.type: Easing.InOutSine
}
}
Behavior on y {
Ext.NumberAnimation {
duration: 120
easing.type: Easing.InOutSine
}
}
// final animation
Ext.RotationAnimation {
objectName: "rotate_player"
target: player
property: "rotation"
from: 0; to: 360
duration: 600
}
}

BIN
examples/sokoban/qml/fonts/fontawesome-webfont.ttf Normal file
View file

Binary file not shown.

BIN
examples/sokoban/qml/img/goal.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 284 B

BIN
examples/sokoban/qml/img/object.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 469 B

BIN
examples/sokoban/qml/img/object2.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 478 B

BIN
examples/sokoban/qml/img/player.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 841 B

BIN
examples/sokoban/qml/img/player2.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 841 B

BIN
examples/sokoban/qml/img/wall.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 165 B

155
examples/sokoban/qml/main.qml Normal file
View file

@ -0,0 +1,155 @@
import QtQuick 2.15
import QtQuick.Controls 2.15
import QtQuick.Window 2.15
import "ext/" as Ext
Rectangle {
id: main
width: Screen.desktopAvailableWidth
height: Screen.desktopAvailableHeight
property bool small: (Math.max(width, height) < 1000)
function isLandscape() { return (Screen.primaryOrientation === Qt.LandscapeOrientation) }
Ext.Dynamic {}
Row {
anchors.centerIn: parent
// adapt 'level' and 'board' scale to screen size
scale: isLandscape()
? ((Screen.desktopAvailableHeight - 10) / board.height)
: ((Screen.desktopAvailableWidth - 10) / (board.width + 2 * level.width))
Slider {
id: level
objectName: "level"
height: board.height
orientation: Qt.Vertical
stepSize: 1.0
onValueChanged: Lisp.call("qsoko:set-maze")
}
Rectangle {
id: board
objectName: "board"
width: 512; height: 512
color: "lightsteelblue"
}
// dummy to have it exactly centered
Item {
width: level.width
height: level.height
}
}
Row {
id: buttons1
objectName: "buttons1"
spacing: main.small ? 10 : 15
padding: 10
anchors.bottom: parent.bottom
Ext.Button {
objectName: "previous"
text: "\uf100"
}
Ext.Button {
objectName: "next"
text: "\uf101"
}
}
Row {
id: buttons2
objectName: "buttons2"
spacing: main.small ? 10 : 15
padding: 10
anchors.right: parent.right
anchors.bottom: parent.bottom
Ext.Button {
objectName: "undo"
text: "\uf112"
}
Ext.Button {
objectName: "restart"
text: "\uf0e2"
}
Ext.Button {
objectName: "solve"
text: "\uf17b"
}
}
// container for arrow buttons
Item {
id: arrows
y: buttons1.y - height - (main.small ? 25 : 50)
width: up.width * 3
height: up.height * 3
anchors.margins: 10
anchors.horizontalCenter: buttons2.horizontalCenter
Ext.ArrowButton {
id: up
objectName: "up"
text: "\uf139"
anchors.horizontalCenter: parent.horizontalCenter
}
Ext.ArrowButton {
objectName: "left"
text: "\uf137"
anchors.verticalCenter: parent.verticalCenter
}
Ext.ArrowButton {
objectName: "right"
text: "\uf138"
anchors.verticalCenter: parent.verticalCenter
anchors.right: parent.right
}
Ext.ArrowButton {
objectName: "down"
text: "\uf13a"
anchors.horizontalCenter: parent.horizontalCenter
anchors.bottom: parent.bottom
}
}
// level change animations
Ext.ScaleAnimator {
objectName: "zoom_board_out"
target: board
from: 1.0
to: 0.0
duration: 250
}
Ext.ScaleAnimator {
objectName: "zoom_board_in"
target: board
from: 0.0
to: 1.0
duration: 250
}
// etc
Keys.onPressed: {
if(event.key === Qt.Key_Back) {
event.accepted = true
Lisp.call("qml:qquit")
}
}
FontLoader {
id: fontAwesome
source: "fonts/fontawesome-webfont.ttf"
}
}

26
examples/sokoban/readme.md Normal file
View file

@ -0,0 +1,26 @@
Info
----
This shows how to dynamically create/destroy QML items.
For the game logic please see [cl-sokoban](lisp/3rd-party/); so, this is just
an UI layer on top of that game.
Run
---
```
lqml run.lisp
```
Optionally pass `-slime` to start a Swank server, and connect from Emacs with
`M-x slime-connect`.
During development you can pass `-auto`, which will releoad all QML files after
you made a change to any of them and saved it. For re-initialization after
reloading, file `lisp/qml-reload/on-reloaded` will be loaded.
Closing the window quits the app. If you try to kill it with `ctrl-c`, you need
an additional `ctrl-d` to exit from ECL. To quit from Slime, do `(qq)` which is
short for `(qquit)`.

1
readme.md
View file

@ -48,7 +48,6 @@ port still lacks significant parts of mobile (as of Qt6.2).
TODO
----
* add sokoban example
* add CL REPL example
* add Windows platform
* port to CMake