Retropikzel
/
scheme-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added polygon library, backup

This commit is contained in:
retropikzel 2025-12-25 16:22:53 +02:00
parent 116d39d34a
commit a8ae08e362
2 changed files with 63 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
retropikzel/polygon.scm Normal file
View File

@ -0,0 +1,55 @@
(define (make-rectangle-polygon x y width height)
(list (cons x y)
(cons (+ x width) y)
(cons (+ x width) (+ y height))
(cons x (+ y height))))
(define (make-triangle-polygon x y width height)
(list (cons x y)
(cons (+ x (exact (round (/ width 2))))
(+ y height))
(cons (- x (exact (round (/ width 2))))
(+ y height))))
(define (draw-polygon polygon)
(let* ((first-point #f)
(previous-point #f))
(for-each
(lambda (point)
(when (not first-point)
(set! first-point point)
(set! previous-point first-point))
(draw-line previous-point point)
(set! previous-point point))
polygon)
(when first-point
(draw-line previous-point first-point))))
(define (draw-relative-polygon x y polygon)
(let* ((first-point #f)
(previous-point #f))
(for-each
(lambda (point)
(when (not first-point)
(set! first-point point)
(set! previous-point first-point))
(draw-line (cons (+ (car previous-point) x)
(+ (cdr previous-point) y))
(cons (+ (car point) x)
(+ (cdr point) y)))
(set! previous-point point))
polygon)
(when first-point
(draw-line (cons (+ (car previous-point) x)
(+ (cdr previous-point) y))
(cons (+ (car first-point) x)
(+ (cdr first-point) y))))))
(define (move-polygon polygon x y)
(map (lambda (point)
(cons (+ (car point) x)
(+ (cdr point) y)))
polygon))
(define (rotate-polygon polygon degrees)
(error "WIP"))

8
retropikzel/polygon.sld Normal file
View File

@ -0,0 +1,8 @@
(define-library
(retropikzel polygon)
(import (scheme base))
(export make-rectangle-polygon
make-triangle-polygon
move-polygon
rotate-polygon)
(include "polygon.scm"))