Tmux etc
This commit is contained in:
Ian Keane
parent
276853ba84
commit
1cb167b597
361 changed files with 77302 additions and 4 deletions
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,311 @@
|
|||
(in-package :de.anvi.croatoan.test)
|
||||
|
||||
;; Example from "Land of Lisp", Copyright by Conrad Barski.
|
||||
;; Source: http://landoflisp.com/evolution.lisp
|
||||
;; Unknown licence.
|
||||
|
||||
(defparameter *width* 100)
|
||||
(defparameter *height* 30)
|
||||
(defparameter *jungle* '(45 10 10 10))
|
||||
(defparameter *plant-energy* 80)
|
||||
(defparameter *plants* (make-hash-table :test #'equal))
|
||||
(defparameter *reproduction-energy* 200)
|
||||
|
||||
(defstruct animal x y energy dir genes)
|
||||
|
||||
|
||||
(defun random-plant (left top width height)
|
||||
(let ((pos (cons (+ left (random width))
|
||||
(+ top (random height)))))
|
||||
(setf (gethash pos *plants*) t)))
|
||||
|
||||
(defun add-plants ()
|
||||
;; First one in the jungle.
|
||||
(apply #'random-plant *jungle*)
|
||||
;; Then one in the rest of the world.
|
||||
(random-plant 0 0 *width* *height*))
|
||||
|
||||
;; Define one starting animal.
|
||||
(defparameter *animals*
|
||||
(list (make-animal :x (ash *width* -1)
|
||||
:y (ash *height* -1)
|
||||
:energy 1000
|
||||
:dir 0
|
||||
:genes (loop repeat 8 collect (1+ (random 10))))))
|
||||
|
||||
(defun move- (animal)
|
||||
(let ((dir (animal-dir animal))
|
||||
(x (animal-x animal))
|
||||
(y (animal-y animal)))
|
||||
|
||||
;; If x>width, wrap around the world border with the mod function.
|
||||
(setf (animal-x animal)
|
||||
(mod (+ x (cond ((and (>= dir 2) (< dir 5)) 1)
|
||||
((or (= dir 1) (= dir 5)) 0)
|
||||
(t -1))
|
||||
*width*)
|
||||
*width*))
|
||||
|
||||
;; Down is +1, up is -1.
|
||||
(setf (animal-y animal)
|
||||
(mod (+ y (cond ((and (>= dir 0) (< dir 3)) -1)
|
||||
((and (>= dir 4) (< dir 7)) 1)
|
||||
(t 0))
|
||||
*height*)
|
||||
*height*))
|
||||
|
||||
(decf (animal-energy animal))))
|
||||
|
||||
(defun turn (animal)
|
||||
(let ((x (random (apply #'+ (animal-genes animal)))))
|
||||
(labels ((angle (genes x)
|
||||
(let ((xnu (- x (car genes))))
|
||||
(if (< xnu 0)
|
||||
0
|
||||
(1+ (angle (cdr genes) xnu))))))
|
||||
|
||||
(setf (animal-dir animal)
|
||||
(mod (+ (animal-dir animal)
|
||||
(angle (animal-genes animal) x))
|
||||
8)))))
|
||||
|
||||
(defun eat (animal)
|
||||
(let ((pos (cons (animal-x animal) (animal-y animal))))
|
||||
(when (gethash pos *plants*)
|
||||
(incf (animal-energy animal) *plant-energy*)
|
||||
(remhash pos *plants*))))
|
||||
|
||||
(defun reproduce (animal)
|
||||
(let ((e (animal-energy animal)))
|
||||
(when (>= e *reproduction-energy*)
|
||||
(setf (animal-energy animal) (ash e -1))
|
||||
(let ((animal-nu (copy-structure animal))
|
||||
(genes (copy-list (animal-genes animal)))
|
||||
(mutation (random 8)))
|
||||
;; mutate a random gene by +1 or -1.
|
||||
(setf (nth mutation genes)
|
||||
(max 1 (+ (nth mutation genes) (random 3) -1)))
|
||||
;; deep copy of the gene list.
|
||||
(setf (animal-genes animal-nu) genes)
|
||||
;; push the new animal to the list.
|
||||
(push animal-nu *animals*)))))
|
||||
|
||||
(defun update-world ()
|
||||
;; Remove dead animals.
|
||||
(setf *animals*
|
||||
(remove-if (lambda (animal) (<= (animal-energy animal) 0))
|
||||
*animals*))
|
||||
;; Do what animals do.
|
||||
(mapc (lambda (animal)
|
||||
(turn animal)
|
||||
(move- animal)
|
||||
(eat animal)
|
||||
(reproduce animal))
|
||||
*animals*)
|
||||
;; Grow plants.
|
||||
(add-plants))
|
||||
|
||||
;;; simple non-ncurses version from LOL, prints to REPL.
|
||||
(defun draw-world ()
|
||||
(loop for y
|
||||
below *height*
|
||||
do (progn (fresh-line)
|
||||
;; beginning of the line.
|
||||
(princ "|")
|
||||
(loop for x
|
||||
below *width*
|
||||
do (princ (cond
|
||||
;; if there is one or more animals, print a M.
|
||||
((some (lambda (animal) (and (= (animal-x animal) x)
|
||||
(= (animal-y animal) y)))
|
||||
*animals*)
|
||||
#\M)
|
||||
;; if there is a plant, print *
|
||||
((gethash (cons x y) *plants*) #\*)
|
||||
;; if there is neithe a plant nor an animal, print a space.
|
||||
(t #\space))))
|
||||
;; end of the line.
|
||||
(princ "|"))))
|
||||
|
||||
;; enter a recursive infinite loop as the programs main loop.
|
||||
(defun evolution ()
|
||||
(draw-world)
|
||||
;; add an empty line between worlds.
|
||||
(fresh-line)
|
||||
(let ((str (read-line)))
|
||||
(cond ((equal str "quit") ())
|
||||
(t (let ((x (parse-integer str :junk-allowed t)))
|
||||
(if x
|
||||
(loop for i
|
||||
below x
|
||||
do (update-world)
|
||||
if (zerop (mod i 1000))
|
||||
do (princ #\.))
|
||||
(update-world))
|
||||
(evolution))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; instead of using princ to draw to stdout, use add-string to draw to the curses screen.
|
||||
;; the screen has to be initialized first in the main function evolve.
|
||||
(defun draw-world-croatoan (scr)
|
||||
(loop
|
||||
for y
|
||||
from 0
|
||||
below *height*
|
||||
do (loop
|
||||
for x
|
||||
from 0
|
||||
below *width*
|
||||
do (add-string scr
|
||||
(format nil "~A"
|
||||
(cond
|
||||
;; if there is one or more animals, print a M.
|
||||
((some (lambda (animal) (and (= (animal-x animal) x)
|
||||
(= (animal-y animal) y)))
|
||||
*animals*)
|
||||
#\M)
|
||||
;; if there is a plant, print *
|
||||
((gethash (cons x y) *plants*) #\*)
|
||||
;; if there is neithe a plant nor an animal, print a space.
|
||||
(t #\space)))
|
||||
:y y
|
||||
:x x)))
|
||||
;; refresh the physical screen to dsplay the drawn changes.
|
||||
(refresh scr))
|
||||
|
||||
;; enter a recursive infinite loop as the programs main loop.
|
||||
(defun evolve ()
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(loop
|
||||
initially
|
||||
(draw-world-croatoan scr)
|
||||
|
||||
for ch = (get-char scr)
|
||||
|
||||
while (or (= ch -1) (not (equal (code-char ch) #\q)))
|
||||
do
|
||||
(update-world)
|
||||
(sleep 0.001)
|
||||
(draw-world-croatoan scr))))
|
||||
|
||||
;; uses tagbody to separate between event handling and body.
|
||||
(defun evolve2 ()
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(draw-world-croatoan scr)
|
||||
(refresh scr)
|
||||
|
||||
(loop
|
||||
(tagbody
|
||||
|
||||
;; read a char.
|
||||
(let ((ch (get-char scr)))
|
||||
|
||||
;; if it is -1, just execute the body.
|
||||
;; this is a special event when there is no event.
|
||||
(cond ((= ch -1) (go evolution-body))
|
||||
|
||||
;; And from here we have real key/character events.
|
||||
((equal (code-char ch) #\q) (return))))
|
||||
|
||||
evolution-body
|
||||
|
||||
(update-world)
|
||||
(sleep 0.001)
|
||||
(draw-world-croatoan scr)
|
||||
(refresh scr)))))
|
||||
|
||||
;; uses key-pressed-p to separate between events and the body, instead of loop and tagbody used in 1 and 2.
|
||||
(defun evolve3 ()
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
;(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(draw-world-croatoan scr)
|
||||
|
||||
(loop
|
||||
(if (key-pressed-p scr)
|
||||
(let ((ch (get-char scr)))
|
||||
(cond ((equal (code-char ch) #\q) (return))))
|
||||
(progn
|
||||
(update-world)
|
||||
(sleep 0.001)
|
||||
(draw-world-croatoan scr) )))))
|
||||
|
||||
(defun evolve4 ()
|
||||
"Uses get-event to separate between events and the body, instead of key-pressed-p."
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
;(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(draw-world-croatoan scr)
|
||||
|
||||
(loop
|
||||
(let ((event (get-event scr)))
|
||||
(if event
|
||||
(case event
|
||||
(#\q (return)))
|
||||
(progn
|
||||
(update-world)
|
||||
(sleep 0.001)
|
||||
(draw-world-croatoan scr) ))))))
|
||||
|
||||
(defun evolve5 ()
|
||||
"Use the event-case macro for event handling."
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(draw-world-croatoan scr)
|
||||
|
||||
(event-case (scr event)
|
||||
(#\q (return-from event-case))
|
||||
((nil)
|
||||
(update-world)
|
||||
(sleep 0.001)
|
||||
(draw-world-croatoan scr)))))
|
||||
|
||||
(defun update-game-state (win event)
|
||||
"Main game state update function for evolve6, called during the nil event handling."
|
||||
(declare (ignore event))
|
||||
(update-world)
|
||||
(draw-world-croatoan win))
|
||||
|
||||
(defun evolve6 ()
|
||||
"Use the run-event-loop for event handling."
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(clear scr)
|
||||
|
||||
(setq *width* (width scr))
|
||||
(setq *height* (height scr))
|
||||
|
||||
(bind scr #\q 'exit-event-loop)
|
||||
(bind scr nil 'update-game-state)
|
||||
|
||||
;; For the same effect, set :input-blocking to 1 milisecond.
|
||||
(setf (frame-rate scr) 1000)
|
||||
|
||||
;; Draw the world once before entering the main loop.
|
||||
(draw-world-croatoan scr)
|
||||
|
||||
(run-event-loop scr)))
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
(in-package :de.anvi.croatoan.test)
|
||||
|
||||
;; here the ncurses primitive bindings should be tested.
|
||||
|
||||
(defun nctest ()
|
||||
(%initscr)
|
||||
(%mvaddstr 0 0 "hello there")
|
||||
(%mvaddstr 7 7 "hello there")
|
||||
(%mvaddstr 15 15 "hello there")
|
||||
(%refresh)
|
||||
(%getch)
|
||||
(%endwin))
|
||||
|
||||
(defun nctest2 ()
|
||||
(let ((scr (%initscr)))
|
||||
(%mvaddstr 0 0 "hello there")
|
||||
|
||||
(%wattron scr #x00020000)
|
||||
(%mvaddstr 7 7 "hello there")
|
||||
(%wattroff scr #x00020000)
|
||||
|
||||
(%wattron scr #x80000000)
|
||||
(%mvaddstr 15 15 "hello there")
|
||||
(%wattroff scr #x80000000)
|
||||
|
||||
(%wrefresh scr)
|
||||
(%wgetch scr)
|
||||
(%endwin)))
|
||||
|
||||
(defun nctest3 ()
|
||||
(%initscr)
|
||||
(%start-color)
|
||||
(%init-pair 1 1 3) ; red(1) on yellow(3)
|
||||
|
||||
;; extract and display the foreground and background color numbers from the pair number
|
||||
(with-foreign-objects ((ptr-f :short)
|
||||
(ptr-b :short))
|
||||
(%pair-content 1 ptr-f ptr-b)
|
||||
(%mvaddstr 0 0 (format nil "1 ~A, 3 ~A" (mem-aref ptr-f :short) (mem-aref ptr-b :short))))
|
||||
|
||||
;; extract and display the RGB contents of predefined color no. 3 (yellow).
|
||||
(with-foreign-objects ((ptr-r :short)
|
||||
(ptr-g :short)
|
||||
(ptr-b :short))
|
||||
(%color-content 3 ptr-r ptr-g ptr-b)
|
||||
(%mvaddstr 1 0 (format nil "~3A ~3A ~3A"
|
||||
(mem-aref ptr-r :short)
|
||||
(mem-aref ptr-g :short)
|
||||
(mem-aref ptr-b :short))))
|
||||
(%refresh)
|
||||
(%getch)
|
||||
(%endwin))
|
||||
|
||||
(defun nctest4 ()
|
||||
"Test low-level cchar_t reading and writing.
|
||||
|
||||
The output is:
|
||||
|
||||
a rendered cchar_t
|
||||
97 code of character #\a
|
||||
1 color pair 1
|
||||
00020100 attribute underline #x00020000 OR-ed with bit-shifted color pair 1
|
||||
|
||||
We see that the attr_t slot contains _both_ the attribute _and_ the
|
||||
bit-shifted color pair, as if it were a chtype in ABI5.
|
||||
|
||||
When ABI6 is used, the separate color-pair slot contains the same color
|
||||
pair number.
|
||||
|
||||
The goal is obviously to make the cchar_t usable under both ABI5 and ABI6."
|
||||
(let ((scr (%initscr)))
|
||||
(%start-color)
|
||||
(%init-pair 1 1 3) ; red(1) on yellow(3)
|
||||
|
||||
(with-foreign-objects ((ptr '(:struct cchar_t))
|
||||
(wch 'wchar_t 5))
|
||||
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
|
||||
(setf (mem-aref wch 'wchar_t) (char-code #\a))
|
||||
;;(%setcchar ptr wch attr_t color-pair-number (null-pointer))
|
||||
(%setcchar ptr wch #x00020000 1 (null-pointer))
|
||||
(%wadd-wch scr ptr))
|
||||
|
||||
;; access the struct slots directly using slot pointers
|
||||
(with-foreign-object (ptr '(:struct cchar_t))
|
||||
(%mvwin-wch scr 0 0 ptr)
|
||||
(let* ((char (mem-aref (foreign-slot-pointer ptr '(:struct cchar_t) 'cchar-chars) 'wchar_t 0))
|
||||
(col (foreign-slot-value ptr '(:struct cchar_t) 'cchar-colors))
|
||||
(attr (foreign-slot-value ptr '(:struct cchar_t) 'cchar-attr)))
|
||||
;; char code
|
||||
(%mvaddstr 1 0 (format nil "~A" char))
|
||||
;; color pair number
|
||||
(%mvaddstr 2 0 (format nil "~A" col))
|
||||
;; attr_t in hex.
|
||||
(%mvaddstr 3 0 (format nil "~8,'0x" attr))))
|
||||
|
||||
;; deconstruct cchar_t using getcchar
|
||||
(with-foreign-objects ((wcval '(:struct cchar_t))
|
||||
(wch 'wchar_t 5)
|
||||
(attrs 'attr_t)
|
||||
(color-pair :short))
|
||||
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
|
||||
(%mvwin-wch scr 0 0 wcval)
|
||||
(%getcchar wcval wch attrs color-pair (null-pointer))
|
||||
|
||||
(%mvaddstr 5 0 (format nil "~A" (mem-aref wch 'wchar_t 0)))
|
||||
(%mvaddstr 6 0 (format nil "~A" (mem-aref color-pair :short)))
|
||||
(%mvaddstr 7 0 (format nil "~8,'0x" (mem-aref attrs 'attr_t))))
|
||||
|
||||
(%refresh)
|
||||
(%getch)
|
||||
(%endwin)))
|
||||
|
||||
;; 190302
|
||||
(defun nctest5 ()
|
||||
(let ((scr (%initscr)))
|
||||
(%addstr (format nil "~A~%" "no background "))
|
||||
(%wgetch scr)
|
||||
|
||||
(%wbkgd scr (char-code #\-))
|
||||
(%addstr (format nil "~A~%" "background minus "))
|
||||
(%wgetch scr)
|
||||
|
||||
(%wbkgd scr (char-code #\*))
|
||||
(%addstr (format nil "~A~%" "background star "))
|
||||
(%wgetch scr)
|
||||
|
||||
(%wbkgd scr (char-code #\-))
|
||||
(%addstr (format nil "~A~%" "background minus "))
|
||||
(%wgetch scr)
|
||||
|
||||
(%wbkgd scr (char-code #\+))
|
||||
(%addstr (format nil "~A~%" "background plus "))
|
||||
(%wgetch scr)
|
||||
|
||||
(%wrefresh scr)
|
||||
(%wgetch scr)
|
||||
(%endwin)))
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
(defpackage #:de.anvi.croatoan.test
|
||||
(:documentation "Tests and examples demonstrating the use of the croatoan API.")
|
||||
(:use #:common-lisp #:cffi #:de.anvi.ncurses #:de.anvi.croatoan)
|
||||
(:shadowing-import-from #:de.anvi.croatoan callback)
|
||||
(:export
|
||||
|
||||
;; ncurses.lisp
|
||||
#:nctest
|
||||
#:nctest2
|
||||
#:nctest3
|
||||
#:nctest4
|
||||
#:nctest5
|
||||
|
||||
;; unicode.lisp
|
||||
#:ut01
|
||||
#:ut02
|
||||
#:ut02b
|
||||
#:ut03
|
||||
#:ut04
|
||||
|
||||
;; clos.lisp
|
||||
#:t00
|
||||
#:t01
|
||||
#:t02
|
||||
#:t02a
|
||||
#:t02b
|
||||
#:t02c
|
||||
#:t03
|
||||
#:t03a
|
||||
#:t03a2
|
||||
#:t03b
|
||||
#:t03b2
|
||||
#:t03b3
|
||||
#:t03c
|
||||
#:t03d
|
||||
#:t03d2
|
||||
#:t03e
|
||||
#:t04
|
||||
#:t04a
|
||||
#:t04b
|
||||
#:t05
|
||||
#:t06
|
||||
#:t06a
|
||||
#:t07
|
||||
#:t07a
|
||||
#:t08
|
||||
#:t08a
|
||||
#:t08b
|
||||
#:t08c
|
||||
#:t09
|
||||
#:t09a
|
||||
#:t09b
|
||||
#:t09c
|
||||
#:t10
|
||||
#:t10a
|
||||
#:t11
|
||||
#:t11a
|
||||
#:t12
|
||||
#:t12a
|
||||
#:t12b
|
||||
#:t12c
|
||||
#:t12c2
|
||||
#:t12d
|
||||
#:t13
|
||||
#:t14
|
||||
#:t14a
|
||||
#:t14b
|
||||
#:t14c
|
||||
#:t15
|
||||
#:t15a
|
||||
#:t15b
|
||||
#:t16
|
||||
#:t16a
|
||||
#:t16b
|
||||
#:t16c
|
||||
#:t16d
|
||||
#:t16e
|
||||
#:t16f
|
||||
#:t16g
|
||||
#:t16h
|
||||
#:t16i
|
||||
#:t17
|
||||
#:t17a
|
||||
#:t18
|
||||
#:t18a
|
||||
#:t19
|
||||
#:t19a
|
||||
#:t19b
|
||||
#:t19b2
|
||||
#:t19c
|
||||
#:t19c2
|
||||
#:t19c3
|
||||
#:t19d
|
||||
#:t19e
|
||||
#:t19e2
|
||||
#:t19f
|
||||
#:t19g
|
||||
#:t20
|
||||
#:t20a
|
||||
#:t20b
|
||||
#:t20c
|
||||
#:t21
|
||||
#:t22
|
||||
#:t23
|
||||
#:t24
|
||||
#:t25
|
||||
#:t26
|
||||
#:t27
|
||||
#:t28
|
||||
#:t28a
|
||||
#:t29
|
||||
#:t30
|
||||
#:t31
|
||||
|
||||
;; clos.lisp
|
||||
#:matrix
|
||||
#:matrix2
|
||||
#:matrix3
|
||||
#:matrix4
|
||||
#:snake
|
||||
#:snake2
|
||||
#:tetris
|
||||
#:pipes
|
||||
|
||||
;; evolution.lisp
|
||||
#:evolve5
|
||||
#:evolve6))
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
(in-package :de.anvi.croatoan.test)
|
||||
|
||||
(defun tetris ()
|
||||
(let ((scr (make-instance 'screen :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil)))
|
||||
(unwind-protect
|
||||
|
||||
(let* ((board (make-array '(20 10) :initial-element nil))
|
||||
(pieces
|
||||
|
||||
'((((0 0) (0 1) (0 2) (1 1)) ((0 1) (1 0) (2 1) (1 1)) ((1 0) (0 1) (1 2) (1 1)) ((0 0) (1 0) (2 0) (1 1))) ;T
|
||||
(((0 0) (0 1) (0 2) (1 0)) ((0 0) (0 1) (2 1) (1 1)) ((1 0) (1 1) (1 2) (0 2)) ((0 0) (1 0) (2 0) (2 1))) ;L
|
||||
(((0 0) (0 1) (0 2) (1 2)) ((0 1) (1 1) (2 1) (2 0)) ((0 0) (1 0) (1 2) (1 1)) ((0 0) (0 1) (1 0) (2 0))) ;J
|
||||
(((1 0) (0 1) (0 2) (1 1)) ((0 0) (1 0) (2 1) (1 1)) ((1 0) (0 1) (0 2) (1 1)) ((0 0) (1 0) (2 1) (1 1))) ;S
|
||||
(((0 0) (0 1) (1 2) (1 1)) ((1 0) (0 1) (2 0) (1 1)) ((0 0) (0 1) (1 2) (1 1)) ((1 0) (0 1) (2 0) (1 1))) ;Z
|
||||
(((0 0) (0 1) (1 0) (1 1)) ((0 0) (0 1) (1 0) (1 1)) ((0 0) (0 1) (1 0) (1 1)) ((0 0) (0 1) (1 0) (1 1))) ;O
|
||||
(((0 0) (0 1) (0 2) (0 3)) ((0 0) (1 0) (2 0) (3 0)) ((0 0) (0 1) (0 2) (0 3)) ((0 0) (1 0) (2 0) (3 0)))));I
|
||||
|
||||
(position '(0 3))
|
||||
(orientation 0)
|
||||
(style 0)
|
||||
(piece (nth orientation (nth style pieces))))
|
||||
|
||||
(labels (;; check whether we left the board.
|
||||
(boundary-crossed-p (piece position)
|
||||
(loop
|
||||
for i in piece
|
||||
for j = (mapcar #'+ i position)
|
||||
do
|
||||
(when (or (> (cadr j) 9) (< (cadr j) 0))
|
||||
(return t))))
|
||||
|
||||
(bottom-reached-p (piece position)
|
||||
(loop
|
||||
for i in piece
|
||||
for j = (mapcar #'+ i position)
|
||||
do
|
||||
(when (> (car j) 19)
|
||||
(return t))))
|
||||
|
||||
;; check whether the piece coordinates are non-nil on the board.
|
||||
(collision-occured-p (board piece position)
|
||||
(loop
|
||||
for i in piece
|
||||
for j = (mapcar #'+ i position)
|
||||
do
|
||||
(when (aref board (car j) (cadr j))
|
||||
(return t))))
|
||||
|
||||
(move-permissible-p (board piece next-position)
|
||||
(not (or (boundary-crossed-p piece next-position)
|
||||
(bottom-reached-p piece next-position)
|
||||
(collision-occured-p board piece next-position))))
|
||||
|
||||
(add-new-piece ()
|
||||
(setf style (random 7))
|
||||
(setf orientation 0)
|
||||
(setf piece (elt (elt pieces style) 0))
|
||||
(setf position '(0 3)))
|
||||
|
||||
;; add piece to board.
|
||||
(update-board ()
|
||||
(loop
|
||||
for i in piece
|
||||
for j = (mapcar #'+ i position)
|
||||
do
|
||||
(setf (aref board (car j) (cadr j)) t)))
|
||||
|
||||
(remove-line (board m)
|
||||
(loop for i from m above 0 do
|
||||
(loop for j from 0 to 9 do
|
||||
(setf (aref board i j) (aref board (1- i) j)))))
|
||||
|
||||
;; find geht nicht, wir muessen checken ob _alle_ t sind.
|
||||
(remove-complete-lines ()
|
||||
(loop for i from 0 to 19 do
|
||||
(when (every #'identity (loop for j from 0 to 9 for y = (aref board i j) collect y))
|
||||
(remove-line board i))))
|
||||
|
||||
(draw-board-and-piece ()
|
||||
;; first, draw the board
|
||||
(loop for line from 0 to 19 do
|
||||
(loop for column from 0 to 9 do
|
||||
(move scr line column)
|
||||
(if (aref board line column)
|
||||
(princ "x" scr)
|
||||
(princ "_" scr))))
|
||||
;; add coord of position to every coord of piece
|
||||
;; then draw the piece
|
||||
(loop
|
||||
for i in piece
|
||||
for j = (mapcar #'+ i position)
|
||||
do
|
||||
(move scr (car j) (cadr j))
|
||||
(princ "x" scr))
|
||||
(refresh scr))
|
||||
|
||||
;; down #c(-1 0), left #c(-1 0), right #c(1 0)
|
||||
(move-piece (direction)
|
||||
(let ((next-position (list (- (car position) (imagpart direction))
|
||||
(+ (cadr position) (realpart direction)))))
|
||||
(if (move-permissible-p board piece next-position)
|
||||
(setf position next-position)
|
||||
;; when sideways move not permissible: do nothing.
|
||||
;; when downwards move not permissible: add piece to board, start new piece.
|
||||
(unless (zerop (imagpart direction))
|
||||
(update-board)
|
||||
(remove-complete-lines)
|
||||
(add-new-piece))))
|
||||
(draw-board-and-piece))
|
||||
|
||||
(rotate-piece ()
|
||||
(let ((next-piece (elt (elt pieces style) (mod (+ orientation 1) 4))))
|
||||
(when (move-permissible-p board next-piece position)
|
||||
(setf orientation (mod (+ orientation 1) 4))
|
||||
(setf piece (elt (elt pieces style) orientation))
|
||||
(draw-board-and-piece))))
|
||||
|
||||
(drop-piece ()
|
||||
(loop
|
||||
(let ((next-position (list (1+ (car position)) (cadr position))))
|
||||
(if (move-permissible-p board piece next-position)
|
||||
(setf position next-position)
|
||||
(return))))
|
||||
(update-board)
|
||||
(remove-complete-lines)
|
||||
(add-new-piece)
|
||||
(draw-board-and-piece)))
|
||||
|
||||
;; clear screen before starting.
|
||||
(clear scr)
|
||||
(refresh scr)
|
||||
|
||||
;; navigate with the arrow keys, q to quit.
|
||||
(loop
|
||||
(let ((event (get-event scr)))
|
||||
(if event
|
||||
(case event
|
||||
(:up (rotate-piece))
|
||||
(:down (drop-piece))
|
||||
(:right (move-piece #c(1 0)))
|
||||
(:left (move-piece #c(-1 0)))
|
||||
(#\q (return)))
|
||||
(progn
|
||||
(move-piece #c(0 -1))
|
||||
(sleep 0.3)))))))
|
||||
|
||||
;; cleanly close ncurses at the end.
|
||||
(close scr))))
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
(in-package :de.anvi.croatoan.test)
|
||||
|
||||
;; Tested in xterm and Gnome Terminal.
|
||||
;; Doesn't work in the Linux console and aterm.
|
||||
|
||||
;; Unicode strings are supported by the default non-unicode ncurses API (addstr) as long as libncursesw is used.
|
||||
;; Special wide-char string functions (addwstr, add_wchstr) do not have to be used.
|
||||
(defun ut01 ()
|
||||
(%initscr)
|
||||
|
||||
(%mvaddstr 2 2 "ččććššđđžž")
|
||||
(%mvaddstr 4 6 "öäüüüßß")
|
||||
(%mvaddstr 6 8 "Без муки нет науки - no pain, no gain")
|
||||
(%mvaddstr 8 10 "指鹿為馬 - point deer, make horse")
|
||||
(%mvaddstr 10 12 "μολὼν λαβέ / ΜΟΛΩΝ ΛΑΒΕ - come and get it")
|
||||
|
||||
(%refresh)
|
||||
(%getch)
|
||||
(%endwin))
|
||||
|
||||
;; For displaying single unicode chars, addch functions do not work, and we have to use add_wch explicitly.
|
||||
;; The data type also changes, from the integral chtype for addch, to the cchar_t struct for add_wch.
|
||||
;; Use the cchar type for convert-to-foreign via a plist.
|
||||
;; cchar-chars isnt a pointer to an integer array here, but an integer.
|
||||
(defun ut02 ()
|
||||
(let ((scr (%initscr)))
|
||||
|
||||
;; %add-wch
|
||||
;; Add #\CYRILLIC_SMALL_LETTER_SHA = #\ш to the stdscr.
|
||||
(with-foreign-object (ptr '(:struct cchar))
|
||||
(setf ptr (convert-to-foreign (list 'cchar-attr 0 'cchar-chars (char-code #\ш))
|
||||
'(:struct cchar)))
|
||||
(%add-wch ptr))
|
||||
|
||||
;; %wadd-wch
|
||||
;; #\CYRILLIC_CAPITAL_LETTER_LJE = #\Љ
|
||||
(with-foreign-object (ptr '(:struct cchar))
|
||||
(setf ptr (convert-to-foreign (list 'cchar-attr #x00020000 'cchar-chars (char-code #\Љ))
|
||||
'(:struct cchar)))
|
||||
(%wadd-wch scr ptr))
|
||||
|
||||
(%wrefresh scr)
|
||||
(%wgetch scr)
|
||||
(%endwin)))
|
||||
|
||||
(defun ut02b ()
|
||||
(let ((scr (%initscr)))
|
||||
(%start-color)
|
||||
(%init-pair 1 1 3) ; red(1) on yellow(3)
|
||||
|
||||
;; %wadd-wch
|
||||
;; #\CYRILLIC_CAPITAL_LETTER_LJE = #\Љ
|
||||
(with-foreign-object (ptr '(:struct cchar_t))
|
||||
;; 2 is the attribute, 1 is the color pair, the color doesnt work with convert-to-foreign
|
||||
;;(setf ptr (convert-to-foreign (list 'cchar-attr #x00020100 'cchar-chars (char-code #\Љ) 'cchar-colors 1)
|
||||
;; '(:struct cchar_t)))
|
||||
|
||||
;; we have to set each slot manually in order to make the extended colors work.
|
||||
(setf (foreign-slot-value ptr '(:struct cchar_t) 'cchar-attr) #x00020100)
|
||||
(setf (foreign-slot-value ptr '(:struct cchar_t) 'cchar-colors) 1)
|
||||
;; also with cchar_t, we can not use convert to foreign at all, but have to manually add the char
|
||||
;; at the first place in the char array.
|
||||
(setf (mem-aref
|
||||
(foreign-slot-pointer ptr '(:struct cchar_t) 'cchar-chars)
|
||||
'wchar_t
|
||||
0)
|
||||
(char-code #\Љ))
|
||||
(%wadd-wch scr ptr))
|
||||
|
||||
(%wrefresh scr)
|
||||
(%wgetch scr)
|
||||
(%endwin)))
|
||||
|
||||
;; We do not need special "wide character" functions for displaying single UTF-8 characters.
|
||||
;; We can just use the string output function %waddstr.
|
||||
;; Here, the underlying %waddstr powers the gray stream interface displaying UTF-8.
|
||||
(defun ut03 ()
|
||||
(with-screen (scr)
|
||||
;; Even though we have a control STRING, format still writes the char
|
||||
;; arguments char by char with write-char.
|
||||
(format scr "~C ~A" #\Љ #\ш)
|
||||
(terpri scr)
|
||||
(format scr "Без муки нет науки")
|
||||
(terpri scr)
|
||||
(format scr "指鹿為馬")
|
||||
(terpri scr)
|
||||
(format scr "μολὼν λαβέ / ΜΟΛΩΝ ΛΑΒΕ")
|
||||
(terpri scr)
|
||||
(refresh scr)
|
||||
(get-char scr)))
|
||||
|
||||
;; Use the cchar_t type for setcchar.
|
||||
;; cchar-chars is a pointer to an integer array here, like the C prototype requires.
|
||||
(defun ut04 ()
|
||||
(let ((scr (%initscr)))
|
||||
(%start-color)
|
||||
;; Initialize color pair 1, yellow 3 on red 1.
|
||||
(%init-pair 1 3 1)
|
||||
|
||||
(with-foreign-objects ((ptr '(:struct cchar_t))
|
||||
(wch 'wchar_t 5))
|
||||
;; Reset the wch array to zero.
|
||||
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
|
||||
(setf (mem-aref wch 'wchar_t) (char-code #\ш))
|
||||
;; Create a cchar_t containing #\ш, attribute underline, color pair yellow on red.
|
||||
(%setcchar ptr wch #x00020000 1 (null-pointer))
|
||||
(%wadd-wch scr ptr)
|
||||
(%waddch scr (char-code #\newline))
|
||||
;; Take a look at the plist convert-from-foreign returns from cchar_t.
|
||||
;; Sadly that plist cant be read back because it contains a pointer.
|
||||
;; As of now, the convert-to-foreign function requires foreign values, not pointers.
|
||||
(%waddstr scr (princ-to-string (convert-from-foreign ptr '(:struct cchar)))))
|
||||
|
||||
(%wrefresh scr)
|
||||
(%wgetch scr)
|
||||
(%endwin)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue