foss-mmo/modules/game/tileset.scm
2024-05-26 13:07:47 -04:00

61 lines
2.1 KiB
Scheme

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-module (game tileset)
#:use-module (dom canvas)
#:use-module (dom image)
#:use-module (ice-9 match)
#:use-module (math rect)
#:use-module (srfi srfi-9)
#:export (make-tileset
tileset?
tileset-image
tileset-tile-width
tileset-tile-height
draw-tile))
(define-record-type <tileset>
(%make-tileset image tile-width tile-height tiles)
tileset?
(image tileset-image)
(tile-width tileset-tile-width)
(tile-height tileset-tile-height)
(tiles tileset-tiles))
(define (make-tileset image width height tile-width tile-height)
(let* ((w (quotient width tile-width))
(h (quotient height tile-height))
(tiles (make-vector (* w h))))
(let y-loop ((y 0))
(when (< y h)
(let x-loop ((x 0))
(when (< x w)
(vector-set! tiles (+ (* y w) x)
(make-rect (* x tile-width)
(* y tile-height)
tile-width
tile-height))
(x-loop (1+ x))))
(y-loop (1+ y))))
(%make-tileset image tile-width tile-height tiles)))
(define (draw-tile context tileset idx x y)
(match tileset
(($ <tileset> image _ _ tiles)
(let* ((tile (vector-ref tiles idx))
(sx (rect-x tile))
(sy (rect-y tile))
(w (rect-width tile))
(h (rect-height tile)))
(draw-image context image sx sy w h x y w h)))))