;;; Copyright (C) 2024 David Thompson ;;; ;;; 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 (%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 (($ 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)))))