* Hack, zile, tetris
@ 2012-02-16 6:57 Mike Gran
2012-02-16 13:37 ` Ludovic Courtès
0 siblings, 1 reply; 4+ messages in thread
From: Mike Gran @ 2012-02-16 6:57 UTC (permalink / raw)
To: Guile User
[-- Attachment #1: Type: text/plain, Size: 393 bytes --]
Hi-
Lacking time to complete a more awesome hack by the 16th, attached please
find a decade-old hack that required only slight modification
to make it run anew.
Yeah, Guile Ncurses Tetris.
Or, if you prefer, I have a bug-fix release of my version of the Zile
editor modified to use Guile as its extension language
https://github.com/downloads/spk121/zile/zile-on-guile-0.1.tar.gz
-Mike
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: tetris.scm --]
[-- Type: text/x-scheme; name="tetris.scm", Size: 12496 bytes --]
#!/usr/local/bin/guile \
-e tetris -s
!#
;; Adapted from guile-ncurses 0.1.0 by Dmitry Morozhnikov
;; Copyright (c) 2001 Dmitry Morozhnikov
;; GPL 2
(use-modules (ncurses curses))
(use-modules (srfi srfi-8))
(define mainwin #f)
(define xorigin 5)
(define yorigin 5)
(define fg_char #f)
(define cap_char #f)
(define b1_char #f)
(define b2_char #f)
(define b3_char #f)
(define b4_char #f)
(define figattr #f)
(define capattr #f)
(define boxattr #f)
(define cap-height 22)
(define cap-width 10)
(define cap-correct #f)
(define fig-correct #f)
(define speed #f)
(define tlines #f)
(define figs #f)
(define score #f)
(define inport #f)
(define (tetris-init-screen)
(start-color!)
(noecho!)
(cbreak!)
(keypad! mainwin #t)
(init-pair! 1 COLOR_BLUE COLOR_BLACK)
(init-pair! 2 COLOR_BLUE COLOR_BLACK)
(init-pair! 3 COLOR_WHITE COLOR_BLACK)
(curs-set 0)
(nodelay! mainwin #t)
(set! fg_char (acs-block))
(set! cap_char (acs-block))
(set! b1_char (normal #\.))
(set! b2_char (normal #\.))
(set! b3_char (normal #\space))
(set! b4_char (normal #\space))
(set! figattr (logior (color-pair 1) A_BOLD))
(set! capattr (color-pair 2))
(set! boxattr (color-pair 3))
(set! xorigin (- (quotient (cols) 2) (quotient (* cap-width 2) 2)))
(set! yorigin (- (quotient (lines) 2) (quotient cap-height 2))))
(define (tetris-done-screen)
(standend! mainwin)
(clear mainwin)
(refresh mainwin)
(curs-set 1)
(endwin))
(define (tetris args)
(let ((w (initscr)))
(set! mainwin w)
(tetris-init-screen)
(tetris-loop)
(tetris-done-screen)))
(define figures `(("##"
"##")
("#."
"##"
".#")
(".#"
"##"
"#.")
("#"
"#"
"#"
"#")
("#."
"##"
"#.")
("##"
"#."
"#.")
("##"
".#"
".#")))
(define fig-rotation `((0 0 0 0)
(0 0 0 0)
(0 0 0 0)
(-2 2 -2 2)
(-1 0 0 1)
(0 0 0 0)
(0 0 0 0)))
(define (tetris-loop)
(tetris-draw-box)
(tetris-draw-help)
(letrec ((key #f)
(fig #f)
(cap #f)
(tics #f)
(speedtics #f)
(speedup #f)
(loop (lambda ()
(set! key (getch mainwin))
(cond
((eq? key #\space)
(tetris-drop-fig fig cap)
(set! tics (tms:clock (times))))
((eq? key KEY_UP)
(tetris-try-rotate fig cap)
(set! tics (tms:clock (times))))
((eq? key KEY_LEFT)
(tetris-try-left fig cap)
(set! tics (tms:clock (times))))
((eq? key KEY_RIGHT)
(tetris-try-right fig cap)
(set! tics (tms:clock (times))))
((or (eq? key KEY_REFRESH)
(eq? key (- (char->integer #\L)
(char->integer #\@))))
(clear mainwin)
(tetris-draw-box)
(tetris-draw-help)
(tetris-draw-cap cap)
(tetris-draw-fig fig #t)))
(refresh mainwin)
(if (>= (- (tms:clock (times)) tics) (- 500 (* speed 5)))
(begin
(set! tics (tms:clock (times)))
(if (>= (- (tms:clock (times)) speedtics) speedup)
(begin
(set! speedtics (tms:clock (times)))
(set! speed (1+ speed))
(if (> speed 10)
(set! speed 10))))
(tetris-move-fig fig cap)
(if (eq? fig-correct #f)
(begin
(set! cap (tetris-check-cap cap))
(tetris-draw-cap cap)
(set! fig (tetris-generate-fig))
(tetris-place-fig fig cap)))
(tetris-draw-score speed)
(refresh mainwin)))
(if (not (or (eq? key #\q)
(eq? cap-correct #f)))
(loop)))))
(set! fig (tetris-generate-fig))
(set! cap (tetris-generate-cap))
(tetris-draw-cap cap)
(tetris-place-fig fig cap)
(set! tics (tms:clock (times)))
(set! speed 0)
(set! speedtics (tms:clock (times)))
(set! speedup 10000)
(set! tlines 0)
(set! figs 0)
(set! score 0)
(tetris-draw-score speed)
(refresh mainwin)
(loop)))
(define (tetris-score-fig)
(set! figs (1+ figs))
(set! score (+ score speed)))
(define (tetris-score-line)
(set! tlines (1+ tlines))
(set! score (+ score (* 5 speed))))
(define (tetris-draw-score speed)
(attr-set! mainwin boxattr)
(move mainwin yorigin (- xorigin 18))
(addstr mainwin "SPEED : ")
(addstr mainwin (number->string speed))
(move mainwin (+ yorigin 1) (- xorigin 18))
(addstr mainwin "FIGURES : ")
(addstr mainwin (number->string figs))
(move mainwin (+ yorigin 2) (- xorigin 18))
(addstr mainwin "LINES : ")
(addstr mainwin (number->string tlines))
(move mainwin (+ yorigin 3) (- xorigin 18))
(addstr mainwin "SCORE : ")
(addstr mainwin (number->string score)))
(define (tetris-draw-box)
(attr-set! mainwin boxattr)
(move mainwin yorigin (1- xorigin))
(vline mainwin (acs-vline) cap-height)
(move mainwin (+ yorigin cap-height) (1- xorigin))
(hline mainwin (acs-hline) (+ (* cap-width 2) 2))
(addch mainwin (acs-llcorner))
(move mainwin yorigin (+ xorigin (* cap-width 2)))
(vline mainwin (acs-vline) cap-height)
(move mainwin (+ yorigin cap-height) (+ xorigin (* cap-width 2)))
(addch mainwin (acs-lrcorner)))
(define (tetris-draw-help) '())
(define (tetris-draw-fig fig on)
(letrec ((figview (tetris-figview fig))
(x 0)
(y 0)
(fx (car fig))
(fy (cadr fig))
(draw (lambda (f)
(set! x 0)
(draw-x (car f))
(set! y (1+ y))
(if (not (null? (cdr f)))
(draw (cdr f)))))
(draw-x (lambda (f)
(move mainwin (+ yorigin fy y)
(+ xorigin (* (+ fx x) 2)))
(if (eq? (car f) #\#)
(if on
(begin
(attr-set! mainwin figattr)
(addch mainwin fg_char)
(addch mainwin fg_char))
(begin
(attr-set! mainwin capattr)
(let ((oy (odd? (+ fy y)))
(ox (odd? (+ fx x))))
(cond
((or (and oy ox)
(and (not oy)
(not ox)))
(addch mainwin b1_char)
(addch mainwin b2_char))
(#t
(addch mainwin b3_char)
(addch mainwin b4_char)))))))
(set! x (1+ x))
(if (not (null? (cdr f)))
(draw-x (cdr f))))))
(draw figview)))
(define (tetris-draw-cap cap)
(attr-set! mainwin capattr)
(letrec ((y 0)
(x 0)
(draw (lambda (c)
(move mainwin (+ yorigin y) xorigin)
(set! x 0)
(draw-x (car c))
(set! y (1+ y))
(if (not (null? (cdr c)))
(draw (cdr c)))))
(draw-x (lambda (c)
(if (eq? (car c) #\%)
(begin
(addch mainwin cap_char)
(addch mainwin cap_char))
(begin
(cond
((or (and (odd? y) (odd? x))
(and (even? y) (even? x)))
(addch mainwin b1_char)
(addch mainwin b2_char))
(#t
(addch mainwin b3_char)
(addch mainwin b4_char)))))
(set! x (1+ x))
(if (not (null? (cdr c)))
(draw-x (cdr c))))))
(draw cap)))
(define (tetris-check-cap cap)
(letrec ((dropped 0)
(pattern (make-list cap-width #\%))
(check (lambda (c)
(if (null? c)
`()
(if (equal? (car c) pattern)
(begin
(set! dropped (1+ dropped))
(tetris-score-line)
(append (check (cdr c))))
(append (list (car c)) (check (cdr c))))))))
(letrec ((newcap (check cap))
(head (lambda ()
(if (<= dropped 0)
`()
(begin
(set! dropped (1- dropped))
(append (list (make-list cap-width #\.)) (head)))))))
(append (head) newcap))))
(define (tetris-drop-fig fig cap)
(letrec ((drop (lambda (d)
(let ((cap-tail (tetris-cap-tail fig cap 0 d)))
(if (or (eq? cap-tail #f)
(not (tetris-placeable? fig cap-tail)))
(begin
(if (> d 1)
(begin
(tetris-draw-fig fig #f)
(set-car! (cdr fig) (+ (cadr fig) (1- d)))
(tetris-draw-fig fig #t))))
(drop (1+ d)))))))
(drop 1)))
(define (tetris-generate-cap)
(letrec ((h (- cap-height 1))
(cap (list (make-list cap-width #\.)))
(mkh (lambda ()
(append! cap (list (make-list cap-width #\.)))
(set! h (- h 1))
(if (not (= h 0))
(mkh)))))
(mkh)
(set! cap-correct #t)
cap))
;;; Figure defined as (x y w h rot (rot0 ... rot3)
;;; ((x1y1 x2y1 ... xny1)
;;; (x1y2 x2y2 ... xny2) ... ))
(define (tetris-generate-fig)
(set! fig-correct #t)
(let* ((fignum (random 7))
(figview (map string->list (car (list-tail figures fignum))))
(w (length (car figview)))
(h (length figview)))
(list (- (quotient cap-width 2) (quotient w 2)) 0 w h 0
(car (list-tail fig-rotation fignum)) figview)))
(define (tetris-figview fig)
(car (list-tail fig 6)))
(define (tetris-placeable? fig cap)
(letrec ((figview (tetris-figview fig))
(placeable? (lambda (f c)
(if (or (not (placeable-x? (car f) (car c)))
(and (null? (cdr c))
(not (null? (cdr f)))))
#f
(if (null? (cdr f))
#t
(placeable? (cdr f) (cdr c))))))
(placeable-x? (lambda (f c)
(if (or (and (eq? (car f) #\#)
(eq? (car c) #\%))
(and (null? (cdr c))
(not (null? (cdr f)))))
#f
(if (null? (cdr f))
#t
(placeable-x? (cdr f) (cdr c)))))))
(placeable? figview cap)))
(define (tetris-cap-tail fig cap xshift yshift)
(if (or (< (+ (cadr fig) yshift) 0)
(< (+ (car fig) xshift) 0)
(>= (+ (cadr fig) yshift (- (cadddr fig) 1)) cap-height)
(>= (+ (car fig) xshift (- (caddr fig) 1)) cap-width))
#f
(letrec ((height 0)
(tail (lambda (t)
(if (or (= height (cadddr fig))
(null? (cdr t)))
(list (list-tail (car t) (+ (car fig) xshift)))
(begin
(set! height (1+ height))
(append (list (list-tail (car t)
(+ (car fig) xshift)))
(tail (cdr t))))))))
(tail (list-tail cap (+ (cadr fig) yshift))))))
(define (tetris-place-fig fig cap)
(let ((cap-tail (tetris-cap-tail fig cap 0 0)))
(if (and (not (eq? cap-tail #f))
(tetris-placeable? fig cap-tail))
(begin
(set! cap-correct #t)
(set! fig-correct #t)
(tetris-draw-fig fig #t))
(begin
(set! cap-correct #f)
(set! fig-correct #f)))))
(define (tetris-fix fig cap)
(letrec ((figview (tetris-figview fig))
(fix (lambda (f c)
(fix-x (car f) (car c))
(if (not (null? (cdr f)))
(fix (cdr f) (cdr c)))))
(fix-x (lambda (f c)
(if (eq? (car f) #\#)
(set-car! c #\%))
(if (not (null? (cdr f)))
(fix-x (cdr f) (cdr c))))))
(fix figview cap)))
(define (tetris-move-fig fig cap)
(let ((cap-tail (tetris-cap-tail fig cap 0 1)))
(if (and (not (eq? cap-tail #f))
(tetris-placeable? fig cap-tail))
(begin
(tetris-draw-fig fig #f)
(set-car! (cdr fig) (1+ (cadr fig)))
(tetris-draw-fig fig #t))
(let ((cap-tail (tetris-cap-tail fig cap 0 0)))
(tetris-draw-fig fig #f)
(tetris-fix fig cap-tail)
(tetris-score-fig)
(set! fig-correct #f)))))
(define (tetris-try-left fig cap)
(let ((cap-tail (tetris-cap-tail fig cap -1 0)))
(if (and (not (eq? cap-tail #f))
(tetris-placeable? fig cap-tail))
(begin
(tetris-draw-fig fig #f)
(set-car! fig (1- (car fig)))
(tetris-draw-fig fig #t)))))
(define (tetris-try-right fig cap)
(let ((cap-tail (tetris-cap-tail fig cap 1 0)))
(if (and (not (eq? cap-tail #f))
(tetris-placeable? fig cap-tail))
(begin
(tetris-draw-fig fig #f)
(set-car! fig (1+ (car fig)))
(tetris-draw-fig fig #t)))))
(define (tetris-figrotation fig)
(car (list-tail fig 5)))
(define (tetris-rotate fig)
(letrec ((figview (tetris-figview fig))
(rotation (tetris-figrotation fig))
(rot (lambda (w x h)
(if (< w 0)
h
(rot (1- w)
x
(append h (list (map (lambda (y) (list-ref y w))
x))))))))
(let* ((x (+ (car fig) (list-ref rotation (car (cddddr fig)))))
(newfig (list (if (< x 0)
0
(if (>= (+ x (cadddr fig)) cap-width)
(- x (- (+ x (cadddr fig)) cap-width))
x))
(cadr fig)
(cadddr fig)
(caddr fig)
(if (= (car (cddddr fig)) 3)
0
(1+ (car (cddddr fig))))
rotation
(rot (1- (caddr fig)) figview `()))))
newfig)))
(define (tetris-try-rotate fig cap)
(let* ((rotfig (tetris-rotate fig))
(cap-tail (tetris-cap-tail rotfig cap 0 0)))
(if (and (not (eq? cap-tail #f))
(tetris-placeable? rotfig cap-tail))
(begin
(tetris-draw-fig fig #f)
(set-car! fig (car rotfig))
(set-cdr! fig (cdr rotfig))
(tetris-draw-fig fig #t)))))
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: Hack, zile, tetris
2012-02-16 6:57 Hack, zile, tetris Mike Gran
@ 2012-02-16 13:37 ` Ludovic Courtès
2012-02-16 15:39 ` Mike Gran
0 siblings, 1 reply; 4+ messages in thread
From: Ludovic Courtès @ 2012-02-16 13:37 UTC (permalink / raw)
To: guile-user
Hi Mike,
Mike Gran <spk121@yahoo.com> skribis:
> Yeah, Guile Ncurses Tetris.
Awesome. :-)
It seems to be too fast for me, and to ignore (?) my keystrokes. How
can I make it slower?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: Hack, zile, tetris
2012-02-16 13:37 ` Ludovic Courtès
@ 2012-02-16 15:39 ` Mike Gran
2012-02-16 17:36 ` Andy Wingo
0 siblings, 1 reply; 4+ messages in thread
From: Mike Gran @ 2012-02-16 15:39 UTC (permalink / raw)
To: Ludovic Courtès, guile-user@gnu.org
> From: Ludovic Courtès ludo@gnu.org
> It seems to be too fast for me, and to ignore (?) my keystrokes. How
> can I make it slower?
>
I should have know that using (times) wasn't very portable.
I'll have to redo it with srfi-18 time to be more formal.
To try it now, increase the 500 in line 145
(if (>= (- (tms:clock (times)) tics) (- 500 (* speed 5)))
They keystrokes it is supposed to recognize are up, left, right,
and space.
-Mike
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: Hack, zile, tetris
2012-02-16 15:39 ` Mike Gran
@ 2012-02-16 17:36 ` Andy Wingo
0 siblings, 0 replies; 4+ messages in thread
From: Andy Wingo @ 2012-02-16 17:36 UTC (permalink / raw)
To: Mike Gran; +Cc: Ludovic Courtès, guile-user@gnu.org
On Thu 16 Feb 2012 16:39, Mike Gran <spk121@yahoo.com> writes:
> I should have know that using (times) wasn't very portable.
> I'll have to redo it with srfi-18 time to be more formal.
Or use internal-time-units-per-second, or get-internal-run-time, or
something like that?
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2012-02-16 17:36 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-02-16 6:57 Hack, zile, tetris Mike Gran
2012-02-16 13:37 ` Ludovic Courtès
2012-02-16 15:39 ` Mike Gran
2012-02-16 17:36 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).