Permalink
Browse files

add curses wrapper

  • Loading branch information...
1 parent 602498f commit e11d5ea2b720173e983664822962ea7110e8b69b darius committed Aug 12, 2008
Showing with 454 additions and 2 deletions.
  1. +6 −2 Makefile
  2. +10 −0 README
  3. +168 −0 eg-curst/ed.ts
  4. +147 −0 eg-curst/sokoban.ts
  5. +123 −0 runcurst.c
View
@@ -1,11 +1,15 @@
CFLAGS := -Wall -g2 -O2
+LDFLAGS := -lncurses
all: runtusl
runtusl: runtusl.o tusl.o
-
runtusl.o: runtusl.c tusl.h
+
tusl.o: tusl.c tusl.h
+runcurst: runcurst.o tusl.o
+runcurst.o: runcurst.c tusl.h
+
clean:
- rm -f *.o runtusl
+ rm -f *.o runtusl runcurst
View
10 README
@@ -29,3 +29,13 @@ Or run with no arguments to get an interactive prompt:
$ ./runtusl
( 2 3 + .
5 (
+
+
+CURSES
+
+There's a basic curses wrapper:
+
+ $ make runcurst
+ $ ./runcurst '"eg-curses/sokoban.ts" load play'
+
+(Do it in a terminal window, not under Emacs, etc.)
View
@@ -0,0 +1,168 @@
+:-trailing bl
+:<skip {a u c} u 0= (if) a u ; (then)
+ a u 1- + c@ c - (if) a u ; (then)
+ a u 1- c <skip ;
+
+:allot-filled here {u c a} u allot a u c fill ;
+
+:total-pages (8 constant)
+
+:ctrl 64 - ;
+
+:filename (0 variable)
+
+
+ (screen-setup)
+(screen-size :height (1- constant) :width (constant)
+\(screen-teardown)
+
+:messages (here constant width bl allot-filled)
+
+:notify {str} messages width bl fill
+ messages str str strlen memcpy ;
+
+:.digit {b d} b 2 d - 4* u>> hex-digit messages d + c! ;
+:.notify {b} "" notify b 0 .digit b 1 .digit b 2 .digit ;
+
+:page-size (width height * constant)
+:pages (here constant page-size total-pages * bl allot-filled)
+:page (0 variable)
+:page-clip 0 max total-pages 1- min ;
+:page-move page @ + page-clip page ! ;
+:buffer page @ page-size * pages + ;
+
+:point (0 variable)
+:clip 0 max page-size 1- min ;
+:+point point @ + clip ;
+:move +point point ! ;
+:at point @ buffer + ;
+:+at +point buffer + ;
+
+:coords point @ width /mod ;
+:column coords {c r} c ;
+:row coords {c r} r ;
+:rcolumn width column - ;
+:rrow height row - ;
+
+ :bowdlerize {k} 32 k 127 within (if) k ; (then) bl ;
+
+:replace at c! 1 move ;
+:blanks {n} n 0> (when) bl replace n 1- blanks ;
+
+:scrunch at 1+ at rcolumn 1- memmove ;
+:insert {k} scrunch k replace ;
+
+:tab bl insert column 7 and (when) tab ;
+
+:next-row at rcolumn + ;
+:scroll-down next-row width + next-row rrow 2- width * memmove
+ next-row width bl fill ;
+:newline row height 1- < (when)
+ scroll-down next-row at rcolumn memmove rcolumn blanks ;
+
+:delete at rcolumn 1- {a r}
+ a a 1+ r memmove \XXX what if at start of line?
+ bl a r + c! ;
+:backspace -1 move delete ;
+
+:kill-line at rcolumn bl fill ;
+
+ :start-of-line column negate move ;
+:end-of-line start-of-line
+ at width -trailing {a u} u move ;
+
+:forward-char 1 move ;
+:backward-char -1 move ;
+:forward-line width move ;
+:backward-line width negate move ;
+
+:transpose-chars at c@ -1 +at c@ at c! -1 +at c!
+ 1 move ;
+
+:home 0 point ! ;
+:end buffer page-size -trailing {a u} u point ! ;
+
+:forward-page 1 page-move home ;
+:backward-page -1 page-move home ;
+
+
+:copying absorb {c} c 0< (unless) c emit copying ;
+:copy-to-file "wb" 'copying with-io-on-file ;
+:copy-file {infile outfile}
+ outfile infile "rb" 'copy-to-file with-io-on-file ;
+
+:pad here 512 + ; \ XXX ensure this is available
+
+:backup-filename pad swap strcpy pad "~" strcat pad ;
+
+:backup dup backup-filename copy-file ;
+
+:pristine? (true variable)
+:?backup pristine? @ (when) filename @ backup false pristine? ! ;
+
+:au-type {a u} u (when) a c@ emit a 1+ u 1- au-type ;
+
+:visible-height end row 1+ ;
+
+:save-line width * point ! at width -trailing au-type 10 emit ;
+:save-page page ! visible-height 'save-line for
+ $L ctrl emit ;
+:saving total-pages 'save-page for ;
+:save ?backup
+ filename @ "w" 'saving with-io-on-file
+ 0 page ! 0 point ! ; \XXX keep page&point
+
+:snarf1 {c} c 9 = (if) tab ; (then)
+ c 10 = (if) newline ; (then)
+ c $L ctrl = (if) forward-page ; (then)
+ c bowdlerize insert ;
+:snarfing absorb {c} c 0< (unless) c snarf1 snarfing ;
+:snarf "r" 'snarfing with-io-on-file
+ 0 page ! home ;
+
+ :react {k} k $A ctrl = (if) start-of-line ; (then)
+ k $B ctrl = (if) backward-char ; (then)
+ k $D ctrl = (if) delete ; (then)
+ k $E ctrl = (if) end-of-line ; (then)
+ k $F ctrl = (if) forward-char ; (then)
+ k $I ctrl = (if) tab ; (then)
+ k $K ctrl = (if) kill-line ; (then)
+ k $M ctrl = (if) newline ; (then)
+ k $N ctrl = (if) forward-line ; (then)
+ k $P ctrl = (if) backward-line ; (then)
+ k $S ctrl = (if) save ; (then)
+ k $T ctrl = (if) transpose-chars ; (then)
+ k 0x107 = (if) backspace ; (then)
+ k 0x102 = (if) forward-line ; (then)
+ k 0x103 = (if) backward-line ; (then)
+ k 0x104 = (if) backward-char ; (then)
+ k 0x105 = (if) forward-char ; (then)
+ k 0x106 = (if) home ; (then)
+ k 0x14a = (if) delete ; (then)
+ k 0x152 = (if) forward-page ; (then)
+ k 0x153 = (if) backward-page ; (then)
+ k 0x168 = (if) end ; (then)
+ k bowdlerize insert ;
+
+\TO DO:
+\ saving/restoring
+\ tab C-q C-r C-s C-w C-y C-z
+\ M-< M-> M-c M-d M-l M-t M-u M-w M-z
+\ M-left M-right M-up M-down M-a M-e
+
+ :blast-line {i} 0 i i width * buffer + width screen-blast ;
+:blast-page height 'blast-line for
+ 0 height messages width screen-blast ;
+
+:editing blast-page coords screen-refresh
+ get-key {key} key $Q ctrl = (unless)
+ key react
+ key .notify
+ editing ;
+
+:?complain {plaint}
+ plaint (when) plaint type ;
+
+:edit {file} file filename ! true pristine? ! file snarf
+ screen-setup 'editing catch screen-teardown
+ ?complain ;
View
@@ -0,0 +1,147 @@
+\ The sokoban 'level' (the board).
+
+:example-level (
+"# # # # # # #
+# . i # #
+# o @ o #
+# o #
+# . . #
+# @ #
+# # # # # # #
+" constant)
+
+:level-var (example-level variable)
+:level level-var @ ;
+
+:width level 0 10 string-c-index 1+ ;
+
+
+\ The solution record
+
+:moves-size (4096 constant)
+:moves (here constant moves-size allot)
+:moves-ptr (0 variable)
+:moves-at moves-ptr @ {p}
+ 0 p moves-size within (if) p moves + ; (then)
+ "Moves-record out of bounds" throw ;
+:moves-push moves-at c! 1 moves-ptr +! ;
+:moves-pop -1 moves-ptr +! moves-at c@ ;
+:moves-get 0 moves-at c! moves ;
+
+
+\ Squares may be walls ('#') or containers (' ' or '.') with an optional
+\ containee ('o' or 'i').
+
+:kinds ("# oi.@I" constant)
+:containers ("# ..." constant)
+:containees (" oi oi" constant)
+
+:char->kind {c} kinds 0 c string-c-index ;
+:parse char->kind {i} i 0< (if) "Unknown kind" throw ; (then) i ;
+:unparse kinds + c@ ;
+
+:->container parse containers + c@ ;
+:->containee parse containees + c@ ;
+
+:clear? {c} c $ = c $. = or ;
+:pusher? {c} c $i = c $I = or ;
+:barrel? {c} c $o = c $@ = or ;
+
+
+\ Move a pusher or barrel one step.
+
+:split {c} c ->containee c ->container ;
+:join {containee container} container $ = (if) containee ; (then)
+ containee parse 3 + unparse ;
+
+:split! {a} a c@ split a c! ;
+:join! {a} a c@ join a c! ;
+:plop {a dir} a split! a dir + join! ;
+
+
+\ Move a pair of them together.
+
+:plop-plop {a dir} a dir + dir plop a dir plop ;
+
+
+\ Undoably try to move the pusher, pushing any adjacent unblocked barrel.
+
+:no-move {a dir c} ;
+:step-move {a dir c} a dir plop c moves-push ;
+:push-move {a dir c} a dir plop-plop c to-uppercase moves-push ;
+
+:move {a dir c}
+ a dir c a dir + c@ a dir 2* + c@ {s0 s1}
+ s0 clear? (if) step-move ; (then)
+ s0 barrel? s1 clear? and (if) push-move ; (then)
+ no-move ;
+
+\ Undo a move.
+
+:step-unmove plop ;
+:push-unmove {a dir} a dir - dir plop-plop ;
+
+:unmove uppercase? (if) push-unmove ; (then) step-unmove ;
+
+
+\ To move or unmove, we need to find the pusher and the displacement.
+
+:at {a} a c@ pusher? (if) a ; (then)
+ a c@ (if) a 1+ at ; (then)
+ "no pusher!" throw ;
+
+:get-displacement
+ to-lowercase {c}
+ c $u = (if) width negate ; (then)
+ c $d = (if) width ; (then)
+ c $l = (if) -2 ; (then)
+ c $r = (if) 2 ; (then)
+ "Unknown move" throw ;
+
+:push-it {c} level at c get-displacement c move ;
+:undo moves-ptr @ 0> (when)
+ moves-pop {c}
+ level at c get-displacement negate c unmove ;
+
+
+\ The UI
+
+:solved? 0 $o string-c-index -1 = ;
+
+:at-xy level at level - width /mod ;
+:string-blast dup strlen screen-blast ;
+:banner level solved? (if) "yay" ; (then) " " ;
+:update 0 0 banner string-blast
+ 0 2 level string-blast
+ at-xy 2+ screen-refresh ;
+
+:react {key} key 0x104 = (if) $l push-it ; (then)
+ key 0x105 = (if) $r push-it ; (then)
+ key 0x103 = (if) $u push-it ; (then)
+ key 0x102 = (if) $d push-it ; (then)
+ key $u = (if) undo ; (then)
+ ;
+:playing update
+ get-key {key} key $q = (unless)
+ key react
+ playing ;
+
+:?complain {plaint}
+ plaint (when) plaint type cr ;
+:play screen-setup 'playing catch screen-teardown ?complain ;
+
+
+\ Load a level from a file, play it, and append any solution to the same file.
+
+:snarfing absorb {c} c 0< (unless) c c, snarfing ;
+:snarf {filename}
+ here level-var !
+ filename "r" 'snarfing with-io-on-file
+ 0 c, ;
+
+:type-line type cr ;
+:file-append "a" 'type-line with-io-on-file ;
+
+:play-file {filename}
+ filename snarf play
+ level solved? (if) moves-get filename file-append (then) ;
Oops, something went wrong.

0 comments on commit e11d5ea

Please sign in to comment.