■

gaucheのrfbライブラリで簡単に描画出来ると言う事でちょっと遊んでみる。ブロックが落ちて回転させたりしようとするけど、、やっぱスレッドとかtimerをちゃんと実装しないとだめぽ。あとdownloopでエラー吐いてるけど何のエラーかわからない。。stackがオーバーフローしてんのかな

(use rfb)

(define screen-x-ini 10)
(define screen-y-ini 10)
(define screen-width 1000)
(define screen-height 1000)
(define block-width 10)
(define block-height 10)
(define num-wblocks 10)
(define num-hblocks 25)
(define basex 100)
(define basey 100)
(define LATCH 80000)
(define space 32)
(define left 65361)
(define right 65363)
(define down 65364)

(define block1-list
  '((0 . -1) (0 . 0) (0 . 1) (0 . 2)))

(define block2-list
  '((0 . -1) (0 . 0) (0 . 1) (1 . 1)))

(define block3-list
  '((0 . 0) (1 . 0) (0 . 1) (1 . 1)))

(define block4-list
  '((0 . 0) (-1 . 0) (1 . 0) (0 . -1)))

(define block5-list
  '((0 . 0) (1 . 0) (1 . -1) (0 . 1)))

(define (clear-screen)
  (rfb-box 0 0 screen-width screen-height 'white :filled? #t))

(define (make-outline)
  (rfb-box 10 10
           (+ 10 (* block-width num-wblocks))
           (+ 10 (* block-height num-hblocks))
           'black))

(define (make-block x y c)
  (rfb-box x y (+ x block-width) (+ y block-height) c :filled? #t)
  (rfb-box x y (+ x block-width) (+ y block-height) 'black))

(define (clear-block x y)
  (rfb-box x y (+ x block-width) (+ y block-height) 'white :filled? #t))

(define (make-real-pos-x x)
  (+ screen-x-ini (* x block-width)))

(define (make-real-pos-y y)
  (+ screen-y-ini (* y block-height)))

(define (print-block x y color blist)
  (let ((basex (make-real-pos-x x))
        (basey (make-real-pos-y y)))
    (with-rfb-transaction
     (lambda ()
       (for-each (lambda (list)
                   (let* ((relx (car list))
                          (rely (cdr list))
                          (rx (make-real-pos-x relx))
                          (ry (make-real-pos-y rely)))
                     (make-block (+ basex rx) (+ basey ry) color)))
                 blist)
       blist))))

(define (clear-blocks x y blist)
  (let ((basex (make-real-pos-x x))
        (basey (make-real-pos-y y)))
    (with-rfb-transaction
     (lambda ()
       (for-each (lambda (list)
                   (let* ((relx (car list))
                          (rely (cdr list))
                          (rx (make-real-pos-x relx))
                          (ry (make-real-pos-y rely)))
                     (clear-block (+ basex rx) (+ basey ry))))
                 blist)
       blist))))

(define (rot-block cur-blist)
  (let ((newlist '()))
    (for-each (lambda (list)
                (let ((x (+ (* 0 (car list)) (* -1 (cdr list))))
                      (y (+ (* 1 (car list)) (* 0 (cdr list)))))
                  (set! newlist (cons (cons x y) newlist))))
              cur-blist)
    newlist))

(define (downloop)
  (let loop ((count 0) (x 5) (y 5) (cur-blist block5-list))
    (let* ((key-list (rfb-read-key-event #f)))
      (if (eq? key-list #f)
          (if (= (remainder count LATCH) 0)
              (let ()
                (clear-blocks x y cur-blist)
                (print-block x (+ y 1) "red" cur-blist)
                (loop (+ count 1) x (+ y 1) cur-blist))
              (if (< count (* LATCH 15))
                  (loop (+ count 1) x y cur-blist)))
          (let ((key-down? (caddr key-list))
                (key (cadddr key-list)))
            (clear-screen)
            (print-block x y "red" cur-blist)
            (if (= key-down? 1)
                (cond ((= key space)
                       (let ((newlist (rot-block cur-blist)))
                         (clear-blocks x y cur-blist)
                         (print-block x y "red" newlist)
                         (loop (+ count 1) x y newlist)))
                      ((= key left)
                       (let ()
                         (clear-blocks x y cur-blist)
                         (print-block (- x 1) y "red" cur-blist)
                         (loop (+ count 1) (- x 1) y cur-blist)))
                      ((= key right)
                       (let ()
                         (clear-blocks x y cur-blist)
                         (print-block (+ x 1) y "red" cur-blist)
                         (loop (+ count 1) (+ x 1) y cur-blist)))
                      ((= key down)
                       (let ()
                         (clear-blocks x y cur-blist)
                         (print-block x (+ y 2) "red" cur-blist)
                         (loop (+ count 1) x (+ y 2) cur-blist)))))
            (loop (+ count 1) x (+ y 1) cur-blist))))))

(rfb-init 400 400 :title "Tetris" :port 8080)
(clear-screen)