192 lines
6.7 KiB
Scheme
192 lines
6.7 KiB
Scheme
(import
|
|
(chicken condition)
|
|
(miscmacros)
|
|
(callable-hash-tables)
|
|
(srfi 1)
|
|
(srfi 133)
|
|
(prefix sdl2 sdl2:)
|
|
(prefix sdl2-image img:)
|
|
(prefix sdl2-ttf ttf:))
|
|
|
|
;; constants
|
|
(define white (sdl2:make-color 255 255 255))
|
|
(define black (sdl2:make-color 0 0 0))
|
|
(define yellow (sdl2:make-color 255 255 0))
|
|
;;;;
|
|
|
|
;; SDL housekeeping
|
|
(sdl2:set-main-ready!)
|
|
(sdl2:init! '(video events))
|
|
(ttf:init!)
|
|
|
|
(on-exit sdl2:quit!)
|
|
|
|
(current-exception-handler
|
|
(let ((original-handler (current-exception-handler)))
|
|
(lambda (exception)
|
|
(sdl2:quit!)
|
|
(original-handler exception))))
|
|
;;;;
|
|
|
|
;; tilesheet
|
|
(define glyphsheet (img:load "16x16-RogueYun-AgmEdit.png")) ; a surface
|
|
|
|
(define CP437->unicode (list #x0000 #x263A #x263B #x2665 #x2666 #x2663 #x2660 #x2022 #x25D8 #x25CB #x25D9 #x2642 #x2640 #x266A #x266B #x263C #x25BA #x25C4 #x2195 #x203C #x00B6 #x00A7 #x25AC #x21A8 #x2191 #x2193 #x2192 #x2190 #x221F #x2194 #x25B2 #x25BC #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F #x00C7 #x00FC #x00E9 #x00E2 #x00E4 #x00E0 #x00E5 #x00E7 #x00EA #x00EB #x00E8 #x00EF #x00EE #x00EC #x00C4 #x00C5 #x00C9 #x00E6 #x00C6 #x00F4 #x00F6 #x00F2 #x00FB #x00F9 #x00FF #x00D6 #x00DC #x00A2 #x00A3 #x00A5 #x20A7 #x0192 #x00E1 #x00ED #x00F3 #x00FA #x00F1 #x00D1 #x00AA #x00BA #x00BF #x2310 #x00AC #x00BD #x00BC #x00A1 #x00AB #x00BB #x2591 #x2592 #x2593 #x2502 #x2524 #x2561 #x2562 #x2556 #x2555 #x2563 #x2551 #x2557 #x255D #x255C #x255B #x2510 #x2514 #x2534 #x252C #x251C #x2500 #x253C #x255E #x255F #x255A #x2554 #x2569 #x2566 #x2560 #x2550 #x256C #x2567 #x2568 #x2564 #x2565 #x2559 #x2558 #x2552 #x2553 #x256B #x256A #x2518 #x250C #x2588 #x2584 #x258C #x2590 #x2580 #x03B1 #x00DF #x0393 #x03C0 #x03A3 #x03C3 #x00B5 #x03C4 #x03A6 #x0398 #x03A9 #x03B4 #x221E #x03C6 #x03B5 #x2229 #x2261 #x00B1 #x2265 #x2264 #x2320 #x2321 #x00F7 #x2248 #x00B0 #x2219 #x00B7 #x221A #x207F #x00B2 #x25A0 #x00A0)) ; from libtcod
|
|
|
|
(define color-key (sdl2:surface-ref glyphsheet 0 0))
|
|
|
|
(define (make-glyphs xs)
|
|
(let loop ((result (make-callable-hash-table))
|
|
(xs xs)
|
|
(cursor (sdl2:make-rect 0 0 16 16))
|
|
(i 0))
|
|
(cond ((null? xs) result)
|
|
(else
|
|
(let ((glyph-surf (sdl2:make-surface 16 16 32)))
|
|
(sdl2:blit-surface! glyphsheet cursor glyph-surf #f)
|
|
(set! (sdl2:surface-color-key glyph-surf) color-key)
|
|
(set! (result (car xs)) glyph-surf)
|
|
(set! (sdl2:rect-x cursor) (* 16 (modulo (add1 i) 16)))
|
|
(set! (sdl2:rect-y cursor) (* 16 (quotient (add1 i) 16)))
|
|
(loop result (cdr xs) cursor (add1 i)))))))
|
|
|
|
(define glyphs (make-glyphs CP437->unicode))
|
|
;;;;
|
|
|
|
|
|
;; font setup
|
|
(define font (ttf:open-font "Orbitron-Black.otf" 24))
|
|
;;;;
|
|
|
|
;; SDL window
|
|
(define ww 320)
|
|
(define wh 320)
|
|
(define window (sdl2:create-window! "janus0x1" 'centered 'centered ww wh))
|
|
(define w-surf (sdl2:window-surface window))
|
|
;;;;
|
|
|
|
;; game things
|
|
(define-record thing x y)
|
|
(define player (make-thing (/ ww 2) (/ wh 2))) ; put the player in the middle of the window
|
|
(define npc (make-thing 96 96))
|
|
;;;;
|
|
|
|
;; world
|
|
(define-record tile walkable? clear? dark?)
|
|
(define world
|
|
(vector-unfold (lambda (x) (make-tile #t #t #t)) 400))
|
|
|
|
(vector-for-each
|
|
(lambda (x) (tile-walkable?-set! x #f) (tile-clear?-set! x #f))
|
|
(subvector world 30 33))
|
|
;;;;
|
|
|
|
;; output views
|
|
(define-record view glyph)
|
|
|
|
(define player-view
|
|
(make-view (glyphs #x0040)))
|
|
|
|
(define npc-view
|
|
(make-view (glyphs #x004f)))
|
|
(set! (sdl2:surface-color-mod (view-glyph npc-view)) yellow)
|
|
|
|
; <space>
|
|
(define tile-space-view
|
|
(make-view (glyphs #x0020)))
|
|
|
|
; #
|
|
(define tile-wall-view
|
|
(make-view (glyphs #x0023)))
|
|
;;;;
|
|
|
|
(define (in-bounds? x y)
|
|
(and (<= 0 x) (<= 0 y) (>= (sub1 ww) x) (>= (sub1 wh) y)))
|
|
|
|
(define (walkable? x y)
|
|
(tile-walkable? (vector-ref world (pos->idx x y))))
|
|
|
|
;; actions
|
|
(define (move thing dir)
|
|
(let* ((x (thing-x thing))
|
|
(y (thing-y thing))
|
|
(dirs '((#:up 0 -16) (#:down 0 16) (#:left -16 0) (#:right 16 0)))
|
|
(dx (second (assoc dir dirs)))
|
|
(dy (third (assoc dir dirs)))
|
|
(nx (+ x dx))
|
|
(ny (+ y dy)))
|
|
(when (and (in-bounds? nx ny) (walkable? nx ny))
|
|
(begin
|
|
(thing-x-set! thing nx)
|
|
(thing-y-set! thing ny)))))
|
|
;;;;
|
|
|
|
|
|
;; event handler
|
|
(define (handle-event event exit-main!)
|
|
(case (sdl2:event-type event)
|
|
((quit) (exit-main! #t))
|
|
|
|
((key-down)
|
|
(case (sdl2:keyboard-event-sym event)
|
|
((escape) (exit-main! #t))
|
|
((up) (move player #:up))
|
|
((down) (move player #:down))
|
|
((left) (move player #:left))
|
|
((right) (move player #:right))))))
|
|
;;;;
|
|
|
|
;; rendering
|
|
|
|
(define screen-rects
|
|
(vector-unfold
|
|
(lambda (i) (sdl2:make-rect (* 16 (modulo i (/ ww 16))) (* 16 (quotient i (/ wh 16))) 16 16))
|
|
400))
|
|
|
|
;; if a thing has (x y) how to find which tile to blit it to?
|
|
;; screen-rects is a flattened 2d array of 20 elements per row
|
|
;; So, x will go from 0 to 19 by ones. Just divide x by tile width.
|
|
;; y will go from 0 to 380 by 20s (based on screen height divided by 16).
|
|
;; add x and y to get i.
|
|
|
|
(define (pos->idx x y)
|
|
(+ (/ x 16) (* (/ wh 16) (/ y 16))))
|
|
|
|
;; given an index i, how to find the (x y) where the tile is?
|
|
;; take (304, 0) which is index 19.
|
|
;; x will be (* 16 (modulo i (/ ww 16)))
|
|
;; y will be (* 16 (quotient i (/ wh 16)))
|
|
;; note this is how I create screen-rects, given an index find the x and y
|
|
|
|
(define (idx->pos i)
|
|
(values (* 16 (modulo i (/ ww 16))) (* 16 (quotient i (/ wh 16)))))
|
|
|
|
(define (draw-world! xs)
|
|
(let loop ((xs xs)
|
|
(i 0))
|
|
(cond ((tile-walkable? (vector-ref xs i))
|
|
(sdl2:blit-surface! (view-glyph tile-space-view) #f w-surf (vector-ref screen-rects i)))
|
|
((not (tile-walkable? (vector-ref xs i)))
|
|
(sdl2:blit-surface! (view-glyph tile-wall-view) #f w-surf (vector-ref screen-rects i))))
|
|
(when (> (sub1 (vector-length xs)) i) (loop xs (add1 i)))))
|
|
|
|
(define (redraw!)
|
|
(sdl2:fill-rect! w-surf #f black)
|
|
(draw-world! world)
|
|
(sdl2:blit-surface!
|
|
(view-glyph player-view) #f w-surf (vector-ref screen-rects (pos->idx (thing-x player) (thing-y player))))
|
|
(sdl2:blit-surface!
|
|
(view-glyph npc-view) #f w-surf (vector-ref screen-rects (pos->idx (thing-x npc) (thing-y npc))))
|
|
(sdl2:update-window-surface! window))
|
|
;;;;
|
|
|
|
;; main loop
|
|
(define (main)
|
|
(let/cc exit-main!
|
|
(while #t
|
|
(handle-event (sdl2:wait-event!) exit-main!)
|
|
(redraw!))))
|
|
;;;;
|
|
|
|
(main)
|