Skip to content

Instantly share code, notes, and snippets.

@gpadd
Created January 5, 2012 20:38
Show Gist options
  • Save gpadd/1567171 to your computer and use it in GitHub Desktop.
Save gpadd/1567171 to your computer and use it in GitHub Desktop.
Lame unfinished game
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;;add's contribution
;;;;;;
;;;;;;
;;;;;;
;;;;;;
;;;;;;
(use-modules ((sdl sdl) #:renamer (symbol-prefix-proc '///-))
((sdl gfx) #:renamer (symbol-prefix-proc '/G/-))
((sdl misc-utils) #:renamer (symbol-prefix-proc '/M/-))
((sdl simple) #:renamer (symbol-prefix-proc '/S/-))
((sdl mixer) #:renamer (symbol-prefix-proc '/A/-))
(ice-9 rdelim)
(srfi srfi-9)
(rnrs io ports))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global
(define MAP_WIDTH 40)
(define MAP_HEIGHT 40)
(define TILE_SIZE 16)
(define WWIDTH 640)
(define WHEIGHT 480)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CAnimation
;; Private
(define animation-current-frame 0)
(define animation-frame-inc 0)
(define animation-frame-rate 0)
(define animation-old-time 0)
;; Public
(define animation-max-frames 0)
(define animation-oscillate #f)
(define (animation-set-current-frame frame)
;; TBH I don't see the point of
;; using this if..
(if (not (or (< frame 0)
(> frame animation-max-frames)))
(set! animation-current-frame frame)
#f))
(define (animation-set-frame-rate rate)
(set! animation-frame-rate rate))
(define (animation-get-current-frame)
animation-current-frame)
(define (animation-set-running-on-off true-or-false)
(if (equal? true-or-false #t)
(set! animation-running? #t)
(if (equal? true-or-false #f)
(set! animation-running? #f)
#f)))
(define (animation-set-frame-inc inc)
(set! animation-frame-inc inc))
(define (animation-set-old-time o-time)
(set! animation-old-time o-time))
(define (animation-set-max-frames new-max-frames)
(set! animation-max-frames new-max-frames))
(define (animation-set-oscillator-on-off true-or-false)
(if (equal? true-or-false #t)
(set! animation-oscillate #t)
(if (equal? true-or-false #f)
(set! animation-oscillate #f)
#f)))
(define (animation-get-max-frames)
animation-max-frames)
(define (animation-get-frame-inc)
animation-frame-inc)
(define (animation-get-frame-rate)
animation-frame-rate)
(define (animation-get-old-time)
animation-old-time)
(define (animation-oscillate?)
(if (equal? animation-oscillate #t)
#t
#f))
(define (animation-running?)
(if (equal? animation-running? #t)
#t
#f))
(define (animation-animation)
(animation-set-current-frame 0)
(animation-set-max-frames 8)
(animation-set-frame-inc 1)
(animation-set-frame-rate 1)
(animation-set-old-time 0)
(animation-set-oscillator-on-off #f))
(define (animation-on-animate)
(if (not (> (+ animation-old-time animation-frame-rate) (///-get-ticks)))
(begin
(animation-set-old-time (///-get-ticks))
(if (animation-oscillate?)
(if (> (animation-get-frame-inc) 0)
(if (>= (animation-get-current-frame) (- (animation-get-max-frames) 1))
(animation-set-frame-inc (- (animation-get-frame-inc))))
(if (<= (animation-get-current-frame) 0)
(animation-set-frame-inc (- (animation-get-frame-inc)))))
(if (>= (animation-get-current-frame) (- (animation-get-max-frames) 1))
(animation-set-current-frame 1)))
(animation-set-current-frame (+ (animation-get-current-frame) (animation-get-frame-inc))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CTile
(define TILE_TYPE_NONE 0)
(define TILE_TYPE_NORMAL 1)
(define TILE_TYPE_BLOCK 2)
;; Public
(define-record-type ctile-type
(make-ctile tile-id type-id)
ctile?
(tile-id get-ctile-tile-id set-ctile-tile-id)
(type-id get-ctile-type-id set-ctile-type-id))
(define tile (make-ctile 0 TILE_TYPE_NONE))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Surface
(define dest-r 0)
(define src-r 0)
(define (surface-on-load file)
(define surf-return (///-load-image file))
surf-return)
(define surface-on-draw
(case-lambda ((surf-dest surf-src x y)
(if (not (or (equal? surf-dest 0)
(equal? surf-src 0)))
(begin
(set! dest-r (///-make-rect 0 0 0 0))
(///-rect:set-x! dest-r x)
(///-rect:set-y! dest-r y)
(///-blit-surface surf-src #f surf-dest dest-r)
surf-src)))
((surf-dest surf-src x y x2 y2 w h)
(if (not (or (equal? surf-dest 0)
(equal? surf-src 0)))
(begin
(set! dest-r (///-make-rect 0 0 0 0))
(set! src-r (///-make-rect 0 0 0 0))
(///-rect:set-x! dest-r x)
(///-rect:set-y! dest-r y)
(///-rect:set-x! src-r x2)
(///-rect:set-y! src-r y2)
(///-rect:set-w! src-r w)
(///-rect:set-h! src-r h)
(///-blit-surface surf-src src-r surf-dest dest-r)
surf-src)))))
(define (surface-transparent surf-dest r g b)
(if (not (equal? surf-dest #t))
(begin
(///-set-color-key! surf-dest '(SDL_SRCCOLORKEY SDL_RLEACCEL) (///-map-rgb (///-surface-get-format surf-dest) r g b))
#t)
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Player
(define-record-type player-type
(make-player x
y
on-load
on-loop
on-render
on-clean-up
on-animate
on-collision)
player?
(x get-player-x set-player-x)
(y get-player-y set-player-y)
(entity-on-load get-player-entity-on-load set-player-entity-on-load)
(entity-on-loop get-player-entity-on-loop set-player-entity-on-loop)
(entity-on-render get-player-entity-on-render set-player-entity-on-render)
(entity-on-clean-up get-player-entity-on-clean-up set-player-entity-on-clean-up)
(entity-on-animate get-player-entity-on-animate set-player-entity-on-animate)
(entity-on-collision get-player-entity-collision set-player-entity-on-collision))
(define (player-on-load file width height max-frames)
(if (not (equal? (entity-on-load file width height max-frames) #f))
#t
#f))
(define (player-on-loop)
(entity-on-loop))
(define (player-on-render surf-display)
(entity-on-render surf-display))
(define (player-on-clean-up)
(entity-on-clean-up))
(define (player-on-animate)
(if (not (equal? entity-speed-x 0))
(set! animation-max-frames 8)
(set! animation-max-frames 0))
(entity-on-animate))
(define (player-on-collision entity)
(entity-jump)
#t)
(define (player-player1 file width height max-frames surf-display entity)
(make-player 0
0
(player-on-load file width height max-frames)
(player-on-loop)
(player-on-render surf-display)
(player-on-clean-up)
(player-on-animate)
(player-on-collision entity)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CMap
;; Public
(define cmap-surf-tileset #f)
;; Private
(define (cmap)
(set! cmap-surf-tileset #f))
(define (cmap-on-load file)
(let stuff ((file-handle "")
(temp-tile ""))
(set! cmap-tile-list '())
(open-file file "r")
(if (not (equal? file-handle #f))
(begin
(do ((y 0 (+ y 1)))
((< y '(MAP_HEIGHT)))
(do ((x 0 (+ x 1)))
((< x '(MAP_WIDTH)))
(read-line file-handle)
(set! cmap-tile-list temp-tile))
(read-line file-handle))
#t))))
(define (cmap-on-render surf-display map-x map-y)
(let stuff ((tileset-width 0)
(tileset-height 0)
(id 0)
(tx 0)
(ty 0)
(tileset-x 0)
(tileset-y 0))
(if (not (equal? surf-tileset #f))
(begin (set! tileset-width (/ (///-surface:w surf-tileset) '(TILE_SIZE)))
(set! tileset-height (/ (///-surface:h surf-tileset) '(TILE_SIZE)))
(set! id 0)
(do ((y 0 (+ y 1)))
((< y MAP_HEIGHT))
(do ((x 0 (+ x 1)))
((< x MAP_WIDTH))
(if (equal? (vector-ref cmap-tile-list id) '(TILE_TYPE_NONE)) ;; TileList[ID].TypeID
(set! id (+ id 1)))
(set! tx (+ map-x (* x TILE_SIZE)))
(set! ty (+ map-y (* y TILE_SIZE)))
(set! tileset-x (* (modulo (vector-ref cmap-tile-list id) tileset-width) TILE_SIZE)) ;; TileList[ID].TileID
(set! tileset-y (* (/ (vector-ref cmap-tile-list id) tileset-width) TILE_SIZE)) ;; TileList[ID].TileID
(surface-on-draw surf-display cmap-surf-tileset tx ty tileset-x tileset-y TILE_SIZE TILE_SIZE)
(set! id (+ id 1))))))))
(define (cmap-get-tile x y)
(let stuff ((id 0))
(set! id 0)
(set! id (/ x '(TILE_SIZE)))
(set! id (+ id (* 'MAP_WIDTH (/ y '(TILE_SIZE)))))
(if (or (not (< id 0))
(not (>= id (vector-length (cmap-tile-list)))))
(record-accessor cmap-tile-list id)
#f)))
(define tile-list '())
(define-record-type cmap-type
(make-cmap-t cmap-surf-tileset
tile-list
cmap
cmap-on-load
cmap-on-render
cmap-get-tile)
cmap-t?
(cmap-surf-tileset get-cmap-t-cmap-surf-tileset set-cmap-t-cmap-tileset)
(tile-list get-cmap-t-tile-list set-cmap-t-tile-list)
(cmap get-cmap-t-cmap set-cmap-t-cmap)
(cmap-on-load get-cmap-t-on-load set-cmap-t-on-load)
(cmap-on-render get-cmap-t-on-render set-cmap-t-on-render)
(cmap-get-tile get-cmap-t-cmap-get-tile))
(define cmap-tile-list
(make-cmap-t cmap-surf-tileset
tile-list
cmap
cmap-on-load
cmap-on-render
cmap-get-tile))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utils
(define-syntax dotimes
(syntax-rules ()
((dotimes count body ...)
(let loop ((counter count))
(if (> counter 0)
(begin
body ...
(loop (- counter 1))))))))
(define loop-through-type
(case-lambda ((type0)
(let loop ((i 0)
(type1 type0))
(if (not (equal? type1 '()))
(begin (display type1)
(display i)
(newline)
(loop (+ i 1) (cdr type1)))
(values i type1))))
((type0 stop-at)
(let loop ((i 0)
(type1 type0))
(if (not (or (equal? type1 '())
(>= i (- stop-at 1))))
(begin (display type1)
(display i)
(newline)
(loop (+ i 1) (cdr type1)))
(values i type1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FPS
;; Public
(define fps-control 0)
;; Private
(define fps-old-time 0)
(define fps-last-time 0)
(define fps-speed-factor 0)
(define fps-num-frames 0)
(define fps-frames 0)
(define (fps)
(set! fps-old-time 0)
(set! fps-last-time 0)
(set! fps-speed-factor 0)
(set! fps-frames 0)
(set! fps-num-frames 0))
(define (fps-on-loop)
(if (< (+ fps-old-time 1000) (///-get-ticks))
(begin
(set! fps-old-time (///-get-ticks))
(set! fps-num-frames fps-frames)
(set! fps-frames 0)))
(set! fps-speed-factor (* (/ (- (///-get-ticks) fps-last-time) 1000.0) 32.0))
(set! fps-last-time (///-get-ticks))
(set! fps-frames (+ fps-frames 1)))
(define (fps-get-FPS)
fps-num-frames)
(define (fps-get-speed-factor)
fps-speed-factor)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Event
(define (on-event event)
(if (///-event:type event)
(case (///-event:type event)
((SDL_ACTIVEEVENT)
(case (///-event:active:state event)
((SDL_APPMOUSEFOCUS)
(if (///-event:active:gain event)
(on-mouse-focus)
(on-mouse-blur)))
((SDL_APPINPUTFOCUS)
(if (///-event:active:gain event)
(on-input-focus)
(on-input-blur)))
((SDL_APPACTIVE)
(if (///-event:active:gain event)
(on-restore)
(on-minimize)))))
((SDL_KEYDOWN)
(on-key-down
(///-event:key:keysym:sym event)
(///-event:key:keysym:mod event)
(///-event:key:keysym:unicode event)))
((SDL_KEYUP)
(on-key-up
(///-event:key:keysym:sym event)
(///-event:key:keysym:mod event)
(///-event:key:keysym:unicode event)))
((SDL_MOUSEMOTION)
(on-mouse-move
(///-event:motion:x event)
(///-event:motion:y event)
(///-event:motion:xrel event)
(///-event:motion:yrel event)
(not (equal? (///-event:motion:state event)
'(SDL_BUTTON SDL_BUTTON_RIGHT)
0))
(not (equal? (///-event:motion:state event)
'(SDL_BUTTON SDL_BUTTON_MIDDLE)
0))
(not (equal? (///-event:motion:state event)
'(SDL_BUTTON SDL_BUTTON_LEFT)
0))))
((SDL_MOUSEBUTTONDOWN)
(case (///-event:button:button event)
((SDL_BUTTON_LEFT)
(on-lbutton-down
(///-event:button:x event)
(///-event:button:y event)))
((SDL_BUTTON_RIGHT)
(on-rbutton-down
(///-event:button:x event)
(///-event:button:y event)))
((SDL_BUTTON_MIDDLE)
(on-mbutton-down
(///-event:button:x event)
(///-event:button:y event)))))
((SDL_MOUSEBUTTONUP)
(case (///-event:button:button event)
((SDL_BUTTON_LEFT)
(on-lbutton-up
(///-event:button:x event)
(///-event:button:y event)))
((SDL_BUTTON_RIGHT)
(on-rbutton-up
(///-event:button:x event)
(///-event:button:y event)))
((SDL_BUTTON_MIDDLE)
(on-mbutton-up
(///-event:button:x event)
(///-event:button:y event)))))
((SDL_JOYAXISMOTION)
(on-joy-axis
(///-event:jaxis:which event)
(///-event:jaxis:axis event)
(///-event:jaxis:value event)))
((SDL_JOYBALLMOTION)
(on-joy-ball
(///-event:jball:which event)
(///-event:jball:ball event)
(///-event:jball:xrel event)
(///-event:jball:yrel event)))
((SDL_JOYHATMOTION)
(on-joy-hat
(///-event:jhat:which event)
(///-event:jhat:hat event)
(///-event:jhat:value event)))
((SDL_JOYBUTTONDOWN)
(on-joy-button-down
(///-event:jbutton:which event)
(///-event:jbutton:button event)))
((SDL_JOYBUTTONUP)
(on-joy-button-up
(///-event:jbutton:which event)
(///-event:jbutton:button event)))
((SDL_QUIT)
(on-exit))
((SDL_SYSWMEVENT)
'())
((SDL_VIDEORESIZE)
(on-resize
(///-event:resize:w event)
(///-event:resize:h event)))
((SDL_VIDEOEXPOSE)
(on-expose)))))
(define (on-input-focus) #f)
(define (on-input-blur) #f)
(define (on-key-down sym mod unicode) #f)
(define (on-key-up sym mod unicode) #f)
(define (on-mouse-focus) #f)
(define (on-mouse-blur) #f)
(define (on-mouse-move mx my rel-x rel-y left right middle) #f)
(define (on-mouse-wheel up down) #f)
(define (on-lbutton-down mx my) #f)
(define (on-lbutton-up mx my) #f)
(define (on-rbutton-down mx my) #f)
(define (on-rbutton-up mx my) #f)
(define (on-mbutton-down mx my) #f)
(define (on-mbutton-up mx my) #f)
(define (on-joy-axis which axis vaule) #f)
(define (on-joy-button-down which button) #f)
(define (on-joy-button-up which button) #f)
(define (on-joy-hat which hat value) #f)
(define (on-joy-ball which ball x-rel y-rel) #f)
(define (on-minimize) #f)
(define (on-restore) #f)
(define (on-resize w h) #f)
(define (on-expose) #f)
(define (on-exit) #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entity
(define ENTITY_TYPE_GENERIC 0)
(define ENTITY_TYPE_PLAYER 1)
(define ENTITY_FLAG_NONE 0)
(define ENTITY_FLAG_GRAVITY 1)
(define ENTITY_FLAG_GHOST 2)
(define ENTITY_FLAG_MAPONLY 4)
;; Public
;; Protected
(define eanim-control #t)
(define esurf-entity #f)
;; Public
(define entity-x 0.0)
(define entity-y 0.0)
(define entity-width 0)
(define entity-height 0)
(define entity-move-left #f)
(define entity-move-right #f)
(define entity-type 0)
(define entity-dead #f)
(define entity-eflags 0)
;; Protected
(define entity-speed-x 0.0)
(define entity-speed-y 0.0)
(define entity-accel-x 0.0)
(define entity-accel-y 0.0)
(define entity-can-jump #f)
;; Public
(define entity-max-speed-x 10)
(define entity-max-speed-y 10)
;; Protected
(define entity-current-frame-col 0)
(define entity-current-frame-row 0)
(define entity-col-x 0)
(define entity-col-y 0)
(define entity-col-width 0)
(define entity-col-height 0)
(define (entity)
(set! esurf-entity #f)
(set! entity-x 0)
(set! entity-y 0)
(set! entity-width 0)
(set! entity-height 0)
(set! entity-move-left #f)
(set! entity-move-right #f)
(set! entity-type ENTITY_TYPE_GENERIC)
(set! entity-dead #f)
(set! entity-eflags ENTITY_FLAG_GRAVITY)
(set! entity-speed-x 0.0)
(set! entity-speed-y 0.0)
(set! entity-accel-x 0.0)
(set! entity-accel-y 0.0)
(set! entity-can-jump #f)
(set! entity-max-speed-x 10)
(set! entity-max-speed-y 10)
(set! entity-current-frame-col 0)
(set! entity-col-x 0)
(set! entity-col-y 0)
(set! entity-col-width 0)
(set! entity-col-height 0))
(define (entity-on-load file width height max-frames)
(if (not (equal? (set! (esurf-entity) (surface-on-load file))#f))
(begin
(surface-transparent esurf-entity 255 0 255)
(set! animation-max-frames max-frames)
#t)
#f))
(define (entity-on-loop)
(if (and (equal? entity-move-left #f)
(equal? entity-move-right #f))
(entity-stop-move))
(cond ((entity-move-left)
(set! entity-accel-x (- 0.5)))
((entity-move-right) (set! entity-accel-x 0.5)))
(if (logand entity-eflags ENTITY_FLAG_GRAVITY)
(entity-accel-y 0.75))
(set! entity-speed-x (+ entity-speed-x (* entity-accel-x (fps-get-speed-factor))))
(set! entity-speed-y (+ entity-speed-y (* entity-accel-y (fps-get-speed-factor))))
(if (> entity-speed-x entity-max-speed-x)
(set! entity-speed-x entity-max-speed-x))
(if (> entity-speed-x (- entity-max-speed-x))
(set! entity-speed-x (- entity-max-speed-x)))
(if (> entity-speed-y entity-max-speed-y)
(set! entity-speed-y entity-max-speed-y))
(if (> entity-speed-y entity-max-speed-y)
(set! entity-speed-y (- entity-max-speed-y)))
(entity-on-animate)
(entity-on-move entity-speed-x entity-speed-y))
(define (entity-on-render surf-display)
(if (not (or (equal? esurf-entity #f)
(equal? surf-display #f)))
(surface-on-draw surf-display esurf-entity (- entity-x (camera-get-x)) (- entity-y (camera-get-y)) (* entity-current-frame-col entity-width) (+ entity-current-frame-row (* (+ animation-get-current-frame) entity-height)) entity-width entity-height)))
(define (entity-on-clean-up)
(set! esurf-entity #f))
(define (entity-on-animate)
(cond ((entity-move-left)
(set! entity-current-frame-col 0))
((entity-move-right)
(set! entity-current-frame-col 1)))
(animation-on-animate))
(define (entity-on-collision entity1 entity2)
#t)
(define (entity-on-move move-x move-y)
(let* ((blahblah #t))
(if (not (and (equal? move-x 0)
(equal? move-y 0)))
(let stuff ((new-x 0)
(new-y 0))
(set! entity-can-jump #f)
(set! move-x (* move-x (fps-get-speed-factor)))
(set! move-y (* move-y (fps-get-speed-factor)))
(if (not (equal? move-x))
(cond ((>= move-x 0)
(set! new-x (fps-get-speed-factor)))
(else
(set! new-x (- (fps-get-speed-factor))))))
(if (not (equal? move-y 0))
(cond ((>= move-y 0)
(set! new-y (fps-get-speed-factor)))
(else
(set! new-y (- (fps-get-speed-factor))))))
(while (blahblah)
(cond ((logand entity-eflags ENTITY_FLAG_GHOST)
(entity-pos-valid (+ entity-x new-x) (+ entity-y new-y))
(set! entity-x (+ entity-x new-x))
(set! entity-y (+ entity-y new-y)))
((if (entity-pos-valid (+ entity-x new-x) entity-y)
(set! entity-x (+ entity-x new-x))
(set! entity-speed-x 0)))
((if (entity-pos-valid entity-x (+ entity-y new-y))
(set! entity-y (+ entity-y new-y))
(begin
(if (> move-y 0)
(set! entity-can-jump #t))
(set! entity-speed-y 0)))))
(set! move-x (+ move-x (- new-x)))
(set! move-y (+ move-y (- new-y)))
(if (and (> new-x 0)
(<= move-x 0))
(set! new-x 0))
(if (and (< new-x 0)
(>= move-x 0))
(set! new-x 0))
(if (and (> new-y 0)
(<= move-y 0))
(set! new-x 0))
(if (and (< new-y 0)
(>= move-y 0))
(set! new-x 0))
(if (equal? move-x 0)
(set! new-x 0))
(if (equal? move-y 0)
(set! new-y 0))
(if (and (equal? move-x 0)
(equal? move-y 0))
(set! blahblah #f))
(if (and (equal? new-x 0)
(equal? new-y 0))
(set! blahblah #f)))))))
(define (entity-jump)
(if (not (equal? (entity-can-jump) #f))
(begin
(set! entity-speed-y (- entity-max-speed-y))
#t)
#f))
(define (entity-stop-move)
(if (> entity-speed-x 0)
(set! entity-accel-x (- 1)))
(if (< entity-speed-x 0)
(set! entity-accel-x 1))
(if (and (< entity-speed-x 2.0)
(> entity-speed-x (- 2.0)))
(begin
(set! entity-accel-x 0)
(set! entity-speed-x 0))))
(define (entity-collides ox oy ow oh)
(let stuff ((left1 0)
(left2 0)
(right1 0)
(right2 0)
(top1 0)
(top2 0)
(bottom1 0)
(bottom2 0)
(tx (+ entity-x entity-col-x))
(ty (+ entity-y entity-col-y)))
(set! left1 tx)
(set! left2 ox)
(set! right1 (- (- (+ left1 entity-width) 1) entity-col-width))
(set! right2 (- (+ ox ow) 1))
(set! top1 ty)
(set! top2 oy)
(set! bottom1 (- (- (+ top1 entity-height) 1) entity-col-height))
(set! bottom2 (- (+ oy oh) 1))
(cond ((< bottom1 top2)
#f)
((> top1 bottom2)
#f)
((< right1 left2)
#f)
((> left1 right2)
#f)
(else
#t))))
(define (entity-pos-valid new-x new-y)
(let* ((returns #t)
(start-x (/ (+ new-x entity-col-x) TILE_SIZE))
(start-y (/ (+ new-y entity-col-y) TILE_SIZE))
(end-x (/ (- (- (+ (+ new-x entity-col-x) entity-width) 1) entity-col-width) TILE_SIZE))
(end-y (/ (- (- (+ (+ new-y entity-col-y) entity-height) 1) entity-col-height) TILE_SIZE)))
(do ((iy start-y (+ iy 1)))
((<= iy end-y))
(do ((ix start-y (+ ix 1)))
((<= ix end-x))
(let* ((tile (area-get-tile (* ix TILE_SIZE) (* iy TILE_SIZE))))
(if (equal? (entity-pos-valid-tile tile) #f)
(set! returns #f)))))
(if (logand entity-eflags '(ENTITY_FLAG_MAPONLY))
#f
(do ((i 0 (+ i 1)))
((< i (vector-length entity-list)))
(if (equal? (entity-pos-valid-entity (entity-list i) new-x new-y) #f)
(set! returns #f))))
returns))
(define (entity-pos-valid-tile tile)
(if (not(equal? tile #f))
(if (equal? ctile? TILE_TYPE_BLOCK)
#f
#t)
#t))
(define (entity-pos-valid-entity entity new-x new-y)
(let* ((this-e entity)
(this-x new-x)
(this-y new-y))
(if (and (not (equal? this-e entity))
(not (equal? entity #f))
(equal? (entity-dead entity) #f)
(expt (entity-eflags entity) ENTITY_FLAG_MAPONLY)
(equal? (entity-collides (+ new-x entity-col-x) (+ new-y entity-col-y) (- (- entity-width entity-col-width) 1) (- (- entity-height entity-col-height) 1)) #t))
(begin
(set! entity-a this-e)
(set! entity-b entity)
(entity-col-list (entity-col) entity-col-list)
#f)
#t)))
(define-record-type entity-type
(make-entity eanim-control
esurf-entity
entity-x
entity-y
entity-width
entity-height
entity-move-left
entity-move-right
entity-type
entity-dead
entity-eflags
entity-speed-x
entity-speed-y
entity-accel-x
entity-accel-y
entity-can-jump
entity-max-speed-x
entity-max-speed-y
entity-current-frame-col
entity-current-frame-row
entity-col-x
entity-col-y
entity-col-width
entity-col-height
entity-on-load
entity-on-loop
entity-on-render
entity-on-clean-up
entity-on-animate
entity-on-collision
entity-on-move
entity-jump
entity-stop-move
entity-collides
entity-pos-valid
entity-pos-valid-tile
entity-pos-valid-entity)
entity?
(eanim-control get-entity-eanim-control set-entity-eanim-control)
(esurf-entity get-entity-esurf-entity set-entity-esurf-entity)
(x get-entity-entity-x set-entity-entity-x)
(y get-entity-entity-y set-entity-entity-y)
(width get-entity-entity-width set-entity-entity-width)
(height get-entity-entity-height set-entity-entity-height)
(move-left get-entity-entity-move-left set-entity-entity-move-left)
(move-right get-entity-entity-move-right set-entity-entity-move-right)
(type get-entity-entity-type set-entity-entity-type)
(dead get-entity-entity-dead set-entity-entity-dead)
(eflags get-entity-entity-eflags set-entity-entity-eflags)
(speed-x get-entity-entity-speed-x set-entity-entity-speed-x)
(speed-y get-entity-entity-speed-y set-entity-entity-speed-y)
(accel-x get-entity-entity-accel-x set-entity-entity-accel-x)
(accel-y get-entity-entity-accel-y set-entity-entity-accel-y)
(can-jump get-entity-entity-entity-can-jump set-entity-entity-can-jump)
(max-speed-x get-entity-entity-max-speed-x set-entity-entity-max-speed-x)
(max-speed-y get-entity-entity-max-speed-y set-entity-entity-max-speed-y)
(current-frame-col get-entity-entity-current-frame-col set-entity-entity-current-frame-col)
(current-frame-row get-entity-entity-current-frame-row set-entity-entity-current-frame-row)
(col-x get-entity-entity-col-x set-entity-entity-col-x)
(col-y get-entity-entity-col-y set-entity-entity-col-y)
(col-width get-entity-entity-col-width set-entity-entity-col-width)
(col-height get-entity-entity-col-height set-entity-entity-col-height)
(on-load get-entity-entity-on-load set-entity-entity-on-load)
(on-loop get-entity-entity-on-loop set-entity-entity-on-loop)
(on-render get-entity-entity-on-render set-entity-entity-on-render)
(on-clean-up get-entity-entity-on-clean-up set-entity-entity-on-clean-up)
(on-animate get-entity-entity-on-animate set-entity-entity-on-animate)
(on-collision get-entity-entity-on-collision set-entity-entity-on-collision)
(on-move get-entity-entity-on-move set-entity-entity-on-move)
(jump get-entity-entity-jump set-entity-entity-jump)
(stop-move get-entity-entity-stop-move set-entity-entity-stop-move)
(collides get-entity-entity-collides set-entity-entity-collides)
(pos-valid get-entity-entity-pos-valid set-entity-entity-pos-valid)
(pos-valid-tile get-entity-entity-pos-valid-tile set-entity-entity-pos-valid-tile)
(pos-valid-entity get-entity-entity-pos-valid-entity set-entity-entity-pos-valid-entity))
(define entity-list
(make-entity eanim-control
esurf-entity
entity-x
entity-y
entity-width
entity-height
entity-move-left
entity-move-right
entity-type
entity-dead
entity-eflags
entity-speed-x
entity-speed-y
entity-accel-x
entity-accel-y
entity-can-jump
entity-max-speed-x
entity-max-speed-y
entity-current-frame-col
entity-current-frame-row
entity-col-x
entity-col-y
entity-col-width
entity-col-height
entity-on-load
entity-on-loop
entity-on-render
entity-on-clean-up
entity-on-animate
entity-on-collision
entity-on-move
entity-jump
entity-stop-move
entity-collides
entity-pos-valid
entity-pos-valid-tile
entity-pos-valid-entity))
(define entity-a 0)
(define entity-b 0)
(define (entity-col)
(set! entity-a #f) ;;TODO
(set! entity-b #f))
(define-record-type entity-col-type
(make-entity-col entity-a
entity-b)
entity-col?
(entity-a get-entity-col-entity-a set-entity-col-entity-a)
(entity-b get-entity-col-entity-b set-entity-col-entity-b))
(define entity-col-list (make-entity-col #f #f))
(define entity-col-list-length 2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Camera
(define TARGET_MODE_NORMAL 0)
(define TARGET_MODE_CENTER 0)
(define camera-x 0)
(define camera-y 0)
(define camera-target-x 0.0)
(define camera-target-y 0.0)
(define camera-target-mode 0)
(define (camera)
(let* ((y 0)
(x y)
(target-y #f)
(target-x target-y)
(target-mode 0))
(set! target-mode TARGET_MODE_NORMAL)))
(define (camera-on-move move-x move-y)
(set! camera-x (+ camera-x move-x))
(set! camera-y (+ camera-y move-y)))
(define (camera-get-x)
(if (not (equal? camera-target-x #f))
(if (equal? camera-target-mode TARGET_MODE_CENTER)
(begin
(inexact->exact (- camera-target-x (/ WWIDTH 2)))))
(inexact->exact camera-target-x)))
(define (camera-get-y)
(if (not (equal? camera-target-y #f))
(if (equal? camera-target-mode TARGET_MODE_CENTER)
(inexact->exact (- camera-target-y (/ WWIDTH 2))))
(inexact->exact camera-target-y)))
(define (camera-set-pos x y)
(let stuff ((this-x x)
(this-y y))
this-x
this-y))
(define (camera-set-target x y)
(set! camera-target-x x)
(set! camera-target-y y))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Audio
(define audio-track 0)
(define (open-audio-stuff)
(/A/-open-audio))
(define (close-audio-stuff)
(/A/-close-audio))
(define (pause-audio-stuff)
(/A/-pause-music))
(define (resume-audio-stuff)
(/A/-resume-music))
(define (load-audio-file file)
(set! audio-track (/A/-load-music file)))
(define (load-dummy)
(set! audio-track (/A/-load-music "../sounds/bd_ttr5.xm")))
(define (play-audio)
(/A/-play-music audio-track))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CArea
(define area-control 0)
(define area-size 0)
(define surf-tileset 0)
(define list-sizes 6)
(define-record-type cmap-list-type
(make-cmap surf-tileset
tiled-list
the-cmap
area-on-load
area-on-render
area-get-tile)
cmap?
(surf-tileset get-cmap-surf-tileset set-cmap-surf-tileset)
(tiled-list get-cmap-tiled-list set-cmap-tiled-list)
(the-cmap get-cmap-the-cmap set-cmap-the-cmap)
(on-load get-cmap-area-on-load set-cmap-area-on-load)
(on-render get-cmap-area-on-render set-cmap-area-on-render)
(area-get-tile get-cmap-area-get-tile set-cmap-area-get-tile))
(define tiled-list (make-ctile 0 TILE_TYPE_NONE))
(define (area-on-load file)
(let* ((file-handle (open-file file "r"))
(tileset 0)
(map-file ""))
(define tileset-file (get-string-n file-handle 255))
(if (equal? (set! surf-tileset (surface-on-load tileset-file)) #f)
(close file-handle)
#f)
(get-string-n file-handle 255)
(do ((x 0 (+ x 1)))
((< x area-size))
(do ((y 0 (+ y 1)))
((< y area-size))
(get-string-n file-handle 255)
(if (equal? (area-on-load map-file) #f)
'()
#f)
(set-cmap-surf-tileset temp-map (get-cmap-surf-tileset temp-map))
(set! cmap-list (list cmap-list temp-map))) ;; push_back
(get-string-n file-handle 255))
(close-port file-handle)
(close-port map-file)
#t))
(define (area-on-render surf-display camera-x camera-y)
(define map-width (* MAP_WIDTH TILE_SIZE))
(define map-height (* MAP_HEIGHT TILE_SIZE))
(define first-id (/ (- camera-x) map-width))
(set! first-id (+ first-id (* (/ (- camera-y) map-height) area-size)))
(do ((i 0 (+ i 1)))
((< i 4))
(let* ((id (+ first-id (+ (* (/ i 2) area-size) (modulo i 2))))
(x (+ (* (modulo id area-size) map-width) camera-x))
(y (+ (* (/ id area-size) map-height) camera-y)))
(if (or (< id 0)
(>= id list-sizes))
(set! (get-cmap-area-on-render) (area-on-render surf-display x y))))))
(define (area-on-clean-up)
(set! cmap-list #f))
(define (area-get-map x y)
(let* ((map-width (* MAP_WIDTH TILE_SIZE))
(map-height (* MAP_HEIGHT TILE_SIZE))
(id (/ x map-width)))
(set! id (+ id (* (/ y map-height) area-size)))
(if (not (or (< id 0)
(>= id list-sizes))) ;; size
(loop-through-type cmap-list id)
#f)))
(define (area-get-tile x y)
(let size-stuff ((map-width (* MAP_WIDTH TILE_SIZE))
(map-height (* MAP_HEIGHT TILE_SIZE))
(area-map (area-get-map x y)))
(if (not (equal? area-map #f))
(begin
(set! x (modulo x map-width))
(set! y (modulo y map-height))
(area-get-tile x y))
#f)))
(define cmap-list (make-cmap surf-tileset
tiled-list
cmap
area-on-load
area-on-render
area-get-tile))
(define temp-map (make-cmap surf-tileset
tiled-list
cmap
area-on-load
area-on-render
area-get-tile))
;; Capp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define app-surf-test 0)
(define app-surf-bg 0)
(define app-surf-display (///-set-video-mode WWIDTH WHEIGHT 32 '(SDL_HWSURFACE SDL_DOUBLEBUF)))
(define app-on-render
(case-lambda
(()
(let* ((rect (///-make-rect (- (camera-get-x)) (- (camera-get-y)) 0 0))
(width WWIDTH)
(height WHEIGHT))
(animation-on-animate)
(///-rect:set-x! rect 0)
(///-rect:set-y! rect 0)
(///-rect:set-w! rect width)
(///-rect:set-h! rect height)
(///-fill-rect app-surf-display rect 0)
(area-on-render app-surf-display (- (camera-get-x)) (- (camera-get-y)))
(do ((i 0 (+ i 1)))
((< i 37))
(if (not (entity-list i))
#t)
(set! (entity-list i) app-surf-display))
;;(surface-on-draw app-surf-display app-surf-test 280 155 0 (* (animation-get-current-frame) 64) 64 64)
(///-flip app-surf-display)))
((x y)
(let* ((rect (///-make-rect (apply (- (camera-get-x))) (- (camera-get-y)) 0 0))
(width WWIDTH)
(height WHEIGHT))
(animation-on-animate)
(///-rect:set-x! rect 0)
(///-rect:set-y! rect 0)
(///-rect:set-w! rect width)
(///-rect:set-h! rect height)
(///-fill-rect app-surf-display (- (camera-get-x)) (- (camera-get-y)))
(do ((i 0 (+ i 1)))
((< i 37))
(if (not (entity-list i))
#t)
(set! (entity-list i) app-surf-display))
;;(surface-on-draw app-surf-display app-surf-test x y 0 (* (animation-get-current-frame) 64) 64 64)
(///-flip app-surf-display)))
((x y x2 y2 w h)
(let* ((rect (///-make-rect (- (camera-get-x)) (- (camera-get-y)) 0 0))
(width WWIDTH)
(height WHEIGHT))
(animation-on-animate)
(///-rect:set-x! rect 0)
(///-rect:set-y! rect 0)
(///-rect:set-w! rect width)
(///-rect:set-h! rect height)
(///-fill-rect app-surf-display (- (camera-get-x)) (- (camera-get-y)))
(do ((i 0 (+ i 1)))
((< i 37))
(if (not (entity-list i))
#t)
(set! (entity-list i) app-surf-display))
(surface-on-draw app-surf-display app-surf-bg 0 0 0 0 640 400)
(surface-on-draw app-surf-display app-surf-test x y x2 y2 w h)
(///-flip app-surf-display)))))
(define app-ent-list-len 37)
(define (app-on-loop)
(do ((i 0 (+ i 1)))
((< i app-ent-list-len)) ;; This (vector-length entity-list)
(if (not (entity-list i))
#t
(set! (entity-list i) (entity-on-loop))))
(do ((i 0 (+ i 1)))
((< i entity-col-list-length)) ;; This (vector-length entity-entity-col-list)
(set! entity-a (entity-col-list i))
(set! entity-b (entity-col-list i))
(if (or (equal? entity-a #f)
(equal? entity-b #f))
(if (entity-on-collision entity-a entity-b)
(entity-on-collision entity-b entity-a))))
(set! entity-col-list '())
(fps-on-loop)
(///-set-caption "Hello everyone!" "Hello everyone!"))
(define app-area1 0)
(define (player1 file width height max-frames surf-display entity)
(make-player 0
0
(player-on-load file width height max-frames)
(player-on-loop)
(player-on-render surf-display)
(player-on-clean-up)
(player-on-animate)
(player-on-collision entity)))
(define (app-on-init)
(and (= (///-init '(SDL_INIT_EVERYTHING)) 0)
(if (not (equal? (set! app-surf-display (///-set-video-mode WWIDTH WHEIGHT 32 '(SDL_HWSURFACE SDL_DOUBLEBUF))) #f))
(begin
(set! app-area1 (area-on-load "1.area"))
(///-enable-key-repeat 1 '(SDL_DEFAULT_REPEAT_INTERVAL))
(set! player1 (player-on-load "yoshi.png" 64 64 8))
(set! entity-list (player1 "yoshi.png" 64 64 8 app-surf-display #f))
(set! camera-target-mode TARGET_MODE_CENTER)
(camera-set-target (get-player-x player1) (get-player-y player1))))))
(define (app-on-key-down sym mod unicode)
(cond ((sym '(SDLK_LEFT))
(set! entity-move-left #t))
((sym '(SDLK_RIGHT))
(set! entity-move-right #t))
((sym '(SDLK_SPACE))
(entity-jump))
(#t)))
(define (app-on-key-up sym mod unicode)
(cond ((sym '(SDLK_LEFT))
(set! entity-move-left #f))
((sym '(SDLK_RIGHT))
(set! entity-move-right #f))
(#t)))
(define app-on-clean-up
(case-lambda (()
(area-on-clean-up)
(do ((i 0 (+ i 1)))
((< i 37))
(if (equal? (entity-list i) #f)
(app-on-clean-up (entity-list i))))
(///-quit))
((what)
(area-on-clean-up)
(do ((i 0 (+ i 1)))
((< i 37))
(if (equal? (entity-list i) #f)
(app-on-clean-up (entity-list i))))
(///-quit))))
;; Private
(define app-running? #t)
(define app-player1 0)
;; -.-
(define (capp)
(set! app-surf-display #f)
(set! app-running? #t))
(define app-banana #f)
(define app-event1 #f)
(define (app-on-execute)
(if (not (equal? app-running? #f))
(begin
(app-on-init)
(set! app-banana (///-make-event))
(set! app-event1 (on-event app-banana))
(animation-set-running-on-off #t)
(if (not (equal? (///-init '(SDL_INIT_EVERYTHING)) #f))
(begin
(while animation-running?
(while (///-poll-event app-banana)
(on-event app-banana))
(app-on-loop)
(app-on-render))
(app-on-clean-up)
#f)))
#f))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment