Lista rozwiewająca wątpliwości co do nazewnictwa w tym dokumencie.
bounceable_t - typ zapisany w języku C, który opisuje
dany obiekt, z którym wiązka może się spotkać.document-function - sposób dokumentowania funkcji,
które zdefiniowane zostały w C.Ten plik może być przeglądany jako dokument HTML.
Główna część programu napisana jest w C, jednakże by ułatwić i usprawnić proces tworzenia, wbudowałem do niej interpreter scheme.
Każdy nowy plik w folderze scm/ z rozszerzeniem
.scm będzie linkowany z programem i uruchamiany na samym
początku. Te pliki służą do definiowania "systemowych" funkcji, a więc
(w przyszłości) UI, wszystkiego związanego z przemieszczaniem obiektów
na ekranie, etc.
Rdzeń myślący i obliczający rzeczy zostanie jednak w C.
Aktualną "scenę" można zapisać przez menu (RMB →
zapisz scenę do pliku → nazwa-pliku.scm
RET ), lub wykonując funkcję
(serialize:save-to file-name).
Wbudowane jest też kilka przykładów (zapisane w
scm/e.scm), można je przeglądać przez menu (RMB → załaduj
przykład).
Pliki *.scm można "ładować" po prostu przerzucając je na
działający program - jest to równoważne do
(load file-path).
Proste wyrażenia scheme można wykonywać poprzez kliknięcie klawisze e , po wpisaniu wyrażenia wystarczy kliknąć RET i zostanie ono wyewaluowane.
cały zamysł opiera się na pomyśle hooków (inaczej eventów), nazwę zaciągnąłem prosto z gnu emacs. o danym hooku należy myśleć jak o evencie w JS na stronie internetowej. np.:
const el = document.getElementById("btn");
btn.addEventListener('click', (e) => {
...
});tutaj wygląda tak:
(add-hook
'click
(lambda (first l r)
...))jest wiele różnych rodzajów hooków o które można się
"zaczepić". pełna lista jest w
src/scheme-interop.c.
'keypress - wykonywany za każdym razem gdy klawisz na
klawiaturze jest wciśnięty. jako argumenty przekazuje wciśnięty znak
jako char, oraz jego numeryczną wartość (dla nie-ascii
znaków)'click - wykonywany na każdej klatce, podczas której
wciśnięty jest przycisk myszy. jako argumenty przekazuje
bool czy_pierwsze_przycisniecie, bool czy_lewy
i bool czy_prawy.'unclick - wykonywany podczas klatki w której przycisk
myszy przestanie być wciskany przekazuje takie same argumenty jak
'click'resize - wykonywany za każdym razem jak rozmiar okna
zostanie zmieniony. przekazuje aktualną szerokość i wysokość okna.'clocke - wykonywany co sekundę. przekazuje aktualny
czas.'loge - wykonywany za każdym TraceLog()iem
z C, bądź (tracelog)iem z scheme. przekazuje typ logu i
string z logiem.'new - wykonywany po stworzeniu nowego
bounceable_t - obiektu od którego światło może się odbić.
przekazuje typ stworzonego bounceable (jako symbol).'update - wykonywany za każdym razem, gdy dane
bounceable zostało edytowane. przekazuje typ (j.w.) i
id.'delete - wykonywany za każdym razem, gdy dane
bounceable zostało usunięte. przekazuje typ (j.w.) i
id.'files-dropped - wykonywany, gdy pliki zostały
"wrzucone" do okna (przeniesione z innego programu - drag&drop)'frame - wykonywany co klatkę. UWAGA:
spowalnia mainloop. po wykorzystaniu należy go usunąćhooki dodaje się (j.w.) funkcją add-hook. zwraca ona
id danego hooka, po którym można go potem usunąć. np.:
(define id
(add-hook
'frame
(lambda ()
(draw-text "halo" '(10 . 10) 16 white))))
(wait 2 (lambda () (delete-hook 'frame id)))przez dwie sekundy będzie wyświetlać halo w {x: 10, y:
10}.
tworzenie "własnych obiektów o dowolnym kształcie" odbywa się poprzez
zdefiniowanie ich w języku scheme. są uznawane za normalne
bounceable_t typu B_CUSTOM.
wytłumaczę poprzez przykłady:
(define p1 '(100 . 100))
(define p2 '(150 . 150))
(define p3 '(100 . 400))
(define p4 '(50 . 150))
(define punkty-deltoidu (list p1 p2 p3 p4))
;; L[1-4] to linie w deltoidzie
(define L1 (list p1 p2))
(define L2 (list p2 p3))
(define L3 (list p3 p4))
(define L4 (list p4 p1))
;; p1
;; .
;; L4 / \ L1
;; p4 . . p2
;; \ /
;; L3 \ / L2
;; v
;; p3
;; punkty-deltoidu to wielokąt (poly w customb_data_t), czyli lista punktów.
;; jeśli znajdzie się w niej wiązka światła, program wykona funkcję, która obliczyć ma jak światło powinno się odbić.
;; w tym przypadku będzie to funkcja bounce-fn. dostaje ona jako dane punkt w którym wiązka światła dotknęła wielokątu,
;; oraz kąt względem osi OX
(define (bounce-fn hit-point angle)
(let* ((hit-line
(cond
((point-in-line? hit-point (car L1) (cadr L1) 2) L1) ;; na początek sprawdzamy o jaką linię deltoidu
((point-in-line? hit-point (car L2) (cadr L2) 2) L2) ;; wiązka światła faktycznie się odbiła i zapisujemy ją
((point-in-line? hit-point (car L3) (cadr L3) 2) L3) ;; jako hit-line
((point-in-line? hit-point (car L4) (cadr L4) 2) L4)
(else
(error "not in-line"))))
(hit-angle (normalize-angle (angle-between (car hit-line) (cadr hit-line)))) ;; kąt pod jakim jest linia deltoidu
(rel-angle (- hit-angle angle)) ;; kąt pod jakim światło padło na deltoid
(next-angle (normalize-angle (+ hit-angle rel-angle)))) ;; kąt jaki teraz ma obrać światło
(list hit-point next-angle)))
;; ^^^^^^^^^ ^^^^^^^^^^
;; \____ \_____
;; \ \
;; zwrócić mamy to samo co dostaliśmy, t.j. punkt od którego ma wiązka kontynuować, oraz kąt (względem osi OX)
;; musimy oczywiście też zdefiniować funkcję, która pokaże gdzie ten deltoid jest (t.j. narysuje go)
;; funkcja ta będzie wywoływana za każdym razem gdy klatka ma być narysowana (często) więc powinna być jak najkrótsza.
(define kolor-deltoidu lime-green) ; via scm/colors.scm
(define (draw-fn)
(draw-line p1 p2 1 kolor-deltoidu)
(draw-line p2 p3 1 kolor-deltoidu)
(draw-line p3 p4 1 kolor-deltoidu)
(draw-line p4 p1 1 kolor-deltoidu))
;; na koniec musimy "zarejestrować" deltoid, t.j. przekazać wszystkie informacje o nim programowi
(register-custom
punkty-deltoidu
draw-fn
bounce-fn);; początek i koniec portalu mają takie same wymiary i są równoległe do osi OY,
;; żeby można było łatwo policzyć gdzie światło ma sie znaleźć
(define portal-start '((500 . 500) (500 . 700)))
(define portal-end '((400 . 100) (400 . 200)))
;; portal początkowy rysowany jest kolorem zielonym, a końcowy czerwonym
(define (draw-fn)
(draw-line (car portal-start) (cadr portal-start) 1 green)
(draw-line (car portal-end) (cadr portal-end) 1 red))
(define (light-remap-fn hit-point angle)
(let* ((hit-y (cdr hit-point))
(diff-y (- hit-y (cdr (car portal-start)))) ;; różnica między początkiem (górą) portalu, a miejscem, gdzie wiązka go dotknęła
(end-y (+ (cdr (car portal-end)) diff-y))) ;; finalne y, w którym pojawić ma się wiązka
(list (cons (caar portal-end) end-y) angle)))
;; ^^^^^^^^^^^^^^^^ ^^^^^
;; x portalu końcowego i (y portalu końcowego + diff-y)
(register-custom
portal-start
draw-fn
light-remap-fn)zwraca ile czasu minęło od początku działania programu (wg. raylib -
od InitWindow())
(document-function
(time-since-init)
"zwraca ile czasu minęło od początku działania programu (wg. raylib - od `InitWindow()`)")
zwraca aktualny unix timestamp
(document-function (time) "zwraca aktualny unix timestamp")
wykonuje sh -c $s i zwraca stdout
argumenty
(document-function (system s) "wykonuje `sh -c $s` i zwraca stdout")
kończy program. zwraca status jeśli podany, inaczej
0
argumenty
(document-function (exit . status)
"kończy program. zwraca `status` jeśli podany, inaczej 0")
wykonuje s (to samo co eval, tylko że nie zwraca
wartości i akceptuje string, nie sexp)
argumenty
(document-function
(loads s)
"wykonuje `s` (to samo co eval, tylko że nie zwraca wartości i akceptuje string, nie sexp)")
usuwa hook dla sym o id n
argumenty
hookable_event_t via src/scheme-interop.cadd-hook(document-function
(delete-hook sym n)
"usuwa hook dla `sym` o id `n`"
(args '((sym . "`hookable_event_t` via src/scheme-interop.c")
(n . "id zwrócone przez `add-hook`"))))
zwraca informacje o źródle n
argumenty
(document-function (get-source n) "zwraca informacje o źródle n")
zwraca listę wszystkich źródeł
(document-function (get-all-sources) "zwraca listę wszystkich źródeł")
tworzy zwierciadło
argumenty
(document-function (create-mirror x1 y1 x2 y2) "tworzy zwierciadło")
zwraca pozycje myszki na oknie w postaci (x . y)
(document-function (get-mouse-position)
"zwraca pozycje myszki na oknie w postaci `(x . y)`")
zwraca wielkość okna (w . h)
(document-function (get-screen-size) "zwraca wielkość okna `(w . h)`")
zwraca obecny winconf w postaci jak argumenty do
set-winconf
(document-function
(get-winconf)
"zwraca obecny winconf w postaci jak argumenty do `set-winconf`")
ustawia winconf
argumenty
(r g b a) (można
pominąć a)(document-function
(set-winconf bgcolor mirror-color)
"ustawia winconf"
(args
'((bgcolor . "kolor tła w formacie `(r g b a)` *(można pominąć `a`)*")
(mirror-color . "kolor zwierciadła w formacie j.w."))))
wykonuje TraceLog(T, s)
argumenty
(document-function (real-tracelog t s) "wykonuje TraceLog(T, s)")
lepiej uzywać fill-rect
argumenty
(document-function (real-fill-rect x y w h color) "lepiej uzywać `fill-rect`")
ustawia flagę raylib
argumenty
interop-helpers.scm jako
FLAG-*#t | #f(document-function
(set-window-flag flag v)
"ustawia flagę raylib"
(args '((flag . "flaga zdefiniowana w `interop-helpers.scm` jako `FLAG-*`")
(v . "`#t | #f`"))))
getter dla flagi raylib
argumenty
interop-helpers.scm jako
FLAG-*(document-function
(get-window-flag flag)
"getter dla flagi raylib"
(args '((flag . "flaga zdefiniowana w `interop-helpers.scm` jako `FLAG-*`"))))
zwraca wspólny prostokąt dla r1 i r2. w razie braku, zwraca
(0 0 0 0)
argumenty
(document-function
(rect-collision r1 r2)
"zwraca wspólny prostokąt dla r1 i r2. w razie braku, zwraca `(0 0 0 0)`")
zwraca dane dla bounceable_t od id id
argumenty
(document-function (get-bounceable id)
"zwraca dane dla `bounceable_t` od id `id`")
(document-function (get-all-bounceables) 0)
zmienia dane zwierciadła o id id
argumenty
(document-function (set-mirror! id pt1 pt2)
"zmienia dane zwierciadła o id `id`")
patrz: register-custom
argumenty
(document-function (real-register-custom pts f1 f2) "patrz: register-custom")
tworzy pryzmat ze środkiem pt, długością boku
vert-len i magicznym numerkiem n (wyleciało mi
teraz z głowy jak to się nazywa lol)
argumenty
(document-function
(create-prism pt vert-len n)
"tworzy pryzmat ze środkiem `pt`, długością boku `vert-len` i magicznym numerkiem `n` (wyleciało mi teraz z głowy jak to się nazywa lol)")
zwraca unormalniony prostokąt
argumenty
przykłady
(normalize-rectangle '(10 10 -10 -10)) → '(0 0 10
10)
(document-function
(normalize-rectangle rect)
"zwraca *unormalniony* prostokąt"
(example '((normalize-rectangle '(10 10 -10 -10)) '(0 0 10 10))))
robi raylibowe CheckCollisionPointLine(pt, lp1, lp2, thr)
argumenty
(document-function (point-in-line? pt lp1 lp2 thr)
"robi raylibowe CheckCollisionPointLine(pt, lp1, lp2, thr)")
zwraca kąt pomiędzy p1 a p2 (w
stopniach)
argumenty
(document-function (angle-between p1 p2)
"zwraca kąt pomiędzy `p1` a `p2` (w stopniach)")
zwraca unormalniony kąt
argumenty
przykłady
(normalize-angle 380) → 20
(document-function (normalize-angle ang)
"zwraca *unormalniony* kąt"
(example '((normalize-angle 380) 20)))
Vector2MoveTowards(vec, target, maxlen)
argumenty
(document-function (vec-move-towards vec target maxlen)
"Vector2MoveTowards(vec, target, maxlen)")
(document-function (real-delete-all-sources) nil)
argumenty
(document-function (create-lens center d r) nil)
argumenty
(document-function (delete-bounceable id) nil)
argumenty
(document-function (set-lens! id center d r) nil)
argumenty
(document-function (point-in-lens? pt lens-id) nil)
sprawdza czy kolor jest rozumiany za biały
argumenty
(document-function (white? color)
"sprawdza czy kolor jest rozumiany za biały")
man 3 getenv
argumenty
(document-function (getenv s) "`man 3 getenv`")
(define (e:delete-all)
(delete-all-sources)
(for-each delete-bounceable
(map car (append *mirrors* *customs* *prisms* *lenss*))))
argumenty
(define (load-example n)
((cdr (list-ref *examples* n))))
argumenty
(define (define-example nam user-f)
(let ((f (→
(eval '(e:delete-all))
(user-f)
(tracelog 'info (string-append "załadowano przykład \"" nam "\"")))))
(set! *examples* (append *examples* (list (cons nam f))))))
(define (rand-float)
(/ (random-next) 2147483647))
argumenty
(define (gui/rect rect c)
(let ((x (list-ref rect 0))
(y (list-ref rect 1))
(w (list-ref rect 2))
(h (list-ref rect 3)))
(draw-line `(,(- x 1) unquote y) `(,(+ x w) unquote y) 1 c)
(draw-line `(,x unquote (+ y h)) `(,(+ x w) unquote (+ y h)) 1 c)
(draw-line `(,x unquote y) `(,x unquote (+ y h)) 1 c)
(draw-line `(,(+ x w) unquote y) `(,(+ x w) unquote (+ y h)) 1 c)))
argumenty
(define (gui/window-box-get-empty-space rect)
(list (car rect)
(+ (cadr rect) gui/window-top-bar-size)
(caddr rect)
(- (cadddr rect) gui/window-top-bar-size)))
rysuje bounding-box okienka wraz z tytułem, zwraca miejsce, które pozostało na elementy
argumenty
(x y w h)(define (gui/window-box rect title)
"rysuje bounding-box okienka wraz z tytułem, zwraca miejsce, które pozostało na elementy"
(args '((rect . "prostokąt `(x y w h)`") (title . "tytuł")))
(gui/rect rect (aq 'frame *colorscheme*))
(gui/rect `(,(car rect) ,(cadr rect) ,(caddr rect) ,gui/window-top-bar-size)
(aq 'frame *colorscheme*))
(draw-text title
`(,(car rect) unquote (+ 1 (cadr rect)))
(- gui/window-top-bar-size 2)
(aq 'font *colorscheme*))
(gui/window-box-get-empty-space rect))
rysuje window-box, tylko, że dodaje hooki dla 'frame. zwraca
(destruktor to-co-gui/window-box)
argumenty
(define (gui/window-box-retained rect title)
"rysuje window-box, tylko, że dodaje hooki dla 'frame. zwraca `(destruktor to-co-gui/window-box)`"
(let ((frame-id (add-hook 'frame (→ (gui/window-box rect title)))))
(list (→ (delete-hook 'frame frame-id))
(gui/window-box-get-empty-space rect))))
argumenty
(define (gui/input-box rect text)
(error "not implemented"))
argumenty
(define (gui/label rect text)
(draw-text title
`(,(car rect) unquote (+ 1 (cadr rect)))
(- gui/window-top-bar-size 2)
(aq 'font *colorscheme*)))
argumenty
(define (gui/get-max-text-length-for-width w sz)
(letrec ((f (lambda (s)
(cond
((>= (car (measure-text s sz)) w)
(- (string-length s) 1))
(else
(f (string-append s "a")))))))
(f "a")))
argumenty
(define (gui/multiline-text rect txt cursor-at)
(let* ((w (list-ref rect 2))
(text-height (cdr (measure-text "a" 18)))
(max-len (gui/get-max-text-length-for-width w 18))
(text (map list->string (split-every (string->list txt) max-len)))
(cursor-x (modulo cursor-at max-len))
(cursor-y (round-off (/ cursor-at max-len) 0)))
(for-each
(lambda (n)
(when (equal? n cursor-y)
(let* ((pt-orig (cons
(+
(car rect)
(car
(measure-text (substring (list-ref text n) 0 cursor-x)
18)))
(+ (cadr rect) (* cursor-y text-height))))
(pt (cons (+ 2 (car pt-orig)) (cdr pt-orig))))
(draw-line pt
(cons (car pt) (+ (cdr pt) text-height))
1
(aq 'font *colorscheme*))))
(draw-text
(list-ref text n)
`(,(list-ref rect 0) unquote (+ (list-ref rect 1) (* n text-height) 2))
18
(aq 'font *colorscheme*)))
(iota 0 1 (length text)))))
argumenty
(define (gui/input-popup title callback . force)
(when (or *click-can-be-handled*
force)
(stop-simulation)
(define state "")
(define cursor-at 0)
(set! *current-mode* 'input-popup)
(set! *click-can-be-handled* #f)
(set! *keypress-can-be-handled* #f)
(set! *current-keypress-handler* gui/input-popup:ident)
(set! *current-click-handler* gui/input-popup:ident)
(let*
((frame-handler-id
(add-hook 'frame
(→ (gui/window-box '(100 100 600 400) title)
(gui/multiline-text '(200 200 400 200) state cursor-at))))
(key-handler-id
(add-hook
'keypress
(lambda (c k)
(cond
((and (< k 128)
(> k 31))
(let ((prev (substring state 0 cursor-at))
(rest (substring
state
cursor-at
(+ cursor-at (- (string-length state) cursor-at)))))
(set! state (string-append prev (string c) rest)))
(++ cursor-at))
((eqv? k 259)
(let ((prev (substring state 0 (- cursor-at 1)))
(rest (substring
state
cursor-at
(+ cursor-at (- (string-length state) cursor-at)))))
(set! state (string-append prev rest)))
(-- cursor-at))
((eqv? k 257)
(start-simulation)
(set! *current-mode* nil)
(set! *click-can-be-handled* #t)
(set! *keypress-can-be-handled* #t)
(set! *current-keypress-handler* #f)
(set! *current-click-handler* #f)
(delete-hook 'frame frame-handler-id)
(delete-hook 'keypress key-handler-id)
(callback state))
((eqv? k 263)
(set! cursor-at (max (- cursor-at 1) 0)))
((eqv? k 262)
(set! cursor-at (min (+ cursor-at 1) (string-length state))))))))))))
wyświetla wiadomość
argumenty
(define (gui/message title text timeout . rect)
"wyświetla wiadomość"
(args '((title . "tytuł przekazany do gui/window-box")
(text . "tekst wiadomości")
(timeout . "czas po którym wiadomość znika")
(rect . "rect dla wiadomości (nieobowiązkowy)")))
(let* ((r (if (null? rect)
'(10 10 300 100)
(car rect)))
(id (add-hook 'frame
(→ (let ((r (gui/window-box r title)))
(gui/multiline-text r text))))))
(wait timeout (→ (delete-hook 'frame id)))))
wyświetla gui/message
argumenty
(define (gui/msg text)
"wyświetla gui/message"
(gui/message "" text 5))
argumenty
(x . y)(define (gui/option-menu user-pos opts . exit-handler)
(args '((user-pos . "pozycja lewego-górnego punktu opcji w formie `(x . y)`")
(opts . "opcje w formie ((tekst . funkcja) (tekst . funkcja) ...)")))
(when (or (and *click-can-be-handled*
(eqv? *current-mode* nil))
*gui/option-menu-force-can-be-handled*)
(set! *gui/button:skip-unclick* #t)
(let*
((onexit (if (null? exit-handler)
(→ 0)
(car exit-handler)))
(messages (map car opts))
(measures (map (→1 (measure-text x gui/option-menu:text-size)) messages))
(full-w (+ (* 2 gui/button:padding) (maxl (map car measures))))
(avg-h (avg (map cdr measures)))
(full-h (+ (* avg-h (length opts)) (* gui/button:padding (length opts))))
(full-rect
(gui/rect-fit-into-screen
(list (car user-pos) (cdr user-pos) full-w full-h)))
(pos (cons (car full-rect) (cadr full-rect)))
(rects
(map
(→1 (list (car pos)
(- (+ (cdr pos) x (* x avg-h) (* x gui/button:padding)) x)
full-w
(+ avg-h gui/button:padding)))
(⍳ 0 1 (length opts))))
(destroy-all (→ (for-each (→1 (x)) buttons)
(delete-hook 'frame cursor-handler-id)
(delete-hook 'click c-id)
(set! *gui/option-menu-force-can-be-handled* #f)
(set-cursor mouse-cursor-default)
(onexit)))
(mk-cb (→1 (→ (x) (destroy-all) (onexit))))
(cursor-handler-id
(add-hook 'frame
(→ (if (point-in-rect? (get-mouse-position) full-rect)
(set-cursor mouse-cursor-pointing-hand)
(set-cursor mouse-cursor-default)))))
(buttons
(map
(→1 (let ((opt (list-ref opts x)))
(gui/button (list-ref rects x) (car opt) (mk-cb (cdr opt)) #t)))
(⍳ 0 1 (length opts))))
(c-id
(add-hook
'click
(→3
(when (and (or (not (point-in-rect? (get-mouse-position) full-rect))
z)
(not *gui/button:skip-unclick*))
(destroy-all)))))))))
tworzy przycisk w rect z tekstem zwróconym przez
text-fn. po przyciśnięciu wykonuje cb. zwraca
destruktor - funkcję usuwającą go
argumenty
(define (gui/button-textfn rect text-fn cb . ignore-all)
"tworzy przycisk w `rect` z tekstem zwróconym przez `text-fn`. po przyciśnięciu wykonuje `cb`.\nzwraca **destruktor** - funkcję usuwającą go"
(let ((frame-id (add-hook
'frame
(→
(fill-rect rect (aq 'background *colorscheme*))
(gui/rect rect (aq 'frame *colorscheme*))
(draw-text (text-fn)
(cons (+ (list-ref rect 0) gui/button:padding)
(+ (list-ref rect 1) gui/button:padding))
gui/button:text-size
(aq 'font *colorscheme*)
gui/button:text-spacing))))
(click-id (add-hook
'unclick
(→3 (if *gui/button:skip-unclick*
(set! *gui/button:skip-unclick* #f)
(when (and y
(or *click-can-be-handled*
*gui/button-force-can-be-handled*
ignore-all)
(point-in-rect? (get-mouse-position) rect))
(cb)))))))
(→ (delete-hook 'frame frame-id) (delete-hook 'unclick click-id))))
argumenty
(define (gui/button rect text cb)
(gui/button-textfn rect (→ text) cb))
wykonuje gui/button, tylko sam liczy jak szeroki i wysoki ma być przycisk się zmieścił. zwraca (destruktor szerokosc wysokosc)
argumenty
(define (gui/btn pos text cb)
"wykonuje gui/button, tylko sam liczy jak szeroki i wysoki ma być przycisk się zmieścił. zwraca (destruktor szerokosc wysokosc)"
(args '((pos . "pozycja w formacie (x . y)") (text . "tekst w przycisku")
(cb . "callback")))
(let* ((measure (measure-text text
gui/button:text-size
gui/button:text-spacing))
(w (+ (* 2 gui/button:padding) (car measure)))
(h (+ (* 2 gui/button:padding) (cdr measure))))
(list (gui/button `(,(car pos) ,(cdr pos) ,w ,h) text cb) w h)))
tworzy slider. wywołuje cb z wynikiem za każdym
'unclick eventem. zwraca destruktor.
argumenty
(x y w h)(define (gui/slider rect from to cb)
"tworzy slider. wywołuje `cb` z wynikiem za każdym `'unclick` eventem. zwraca destruktor."
(args '((rect . "w formacie `(x y w h)`") (from . "minimum")
(to . "maksimum")
(cb . "callback")))
(let* ((sl-h (/ (list-ref rect 3) 2))
(sl-w (list-ref rect 2))
(inner-rect (list (list-ref rect 0)
(+ (list-ref rect 1) (/ sl-h 2))
sl-w
sl-h))
(slider-rect nil)
(slider-rect-w 10)
(maxx (- (+ (car rect) sl-w (/ slider-rect-w 2)) slider-rect-w))
(minx (- (car rect) (/ slider-rect-w 2)))
(current-x minx)
(holding #f)
(update-slider-rect (lambda ()
(set! slider-rect
`(,current-x ,(list-ref rect 1)
,slider-rect-w
,(list-ref rect 3)))))
(_ (update-slider-rect))
(frame-id (add-hook
'frame
(→ (fill-rect inner-rect (aq 'background *colorscheme*))
(gui/rect inner-rect (aq 'frame *colorscheme*))
(update-slider-rect)
(fill-rect slider-rect (aq 'frame *colorscheme*))
(let ((mp (get-mouse-position)))
(when *click-can-be-handled*
(if (point-in-rect? mp rect)
(begin
(set! *current-click-handler* gui/slider:ident)
(set! *click-can-be-handled* #f))
(set! *click-can-be-handled* #t)))))))
(click-id (add-hook
'click
(lambda (first l r)
(let ((mp (get-mouse-position)))
(when (or
(and
(or (point-in-rect? mp inner-rect)
(point-in-rect? mp slider-rect))
(or
(or *click-can-be-handled*
*gui/slider-force-can-be-handled*)
(eqv? *current-click-handler* gui/slider:ident))
l
first)
holding)
(set! holding #t)
(set! *click-can-be-handled* #f)
(set! current-x (max2 minx (min2 maxx (car mp))))
(let* ((v (- current-x minx))
(∆range (- to from))
(∆ (/ v sl-w))
(r (* ∆range ∆)))
(cb (+ r from))))))))
(unclick-id (add-hook
'unclick
(→3
(when (or (eqv? *current-click-handler* gui/slider:ident)
*gui/slider-force-can-be-handled*)
(set! holding #f)
(set! *current-click-handler* nil)
(when (not *gui/slider-force-can-be-handled*)
(set! *click-can-be-handled* #t)))))))
(→ (delete-hook 'frame frame-id)
(delete-hook 'click click-id)
(delete-hook 'unclick unclick-id))))
tworzy checkbox. zwraca destruktor.
argumenty
(define (gui/checkbox rect cb . state)
"tworzy checkbox. zwraca destruktor."
(args
'((rect . "prostokąt na checkbox")
(cb . "callback wykonywany po kliknięciu, jako argument przekazuje aktualną wartość (#t | #f)")
(state . "(opcjonalnie) początkowa wartość (#t | #f)")))
(define checked
(if (null? state)
#f
(car state)))
(let* ((padding (/ (list-ref rect 3) 4))
(checked-rect (list (+ padding (list-ref rect 0))
(+ padding (list-ref rect 1))
(- (- (list-ref rect 2) 1) (* 2 padding))
(- (- (list-ref rect 3) 1) (* 2 padding))))
(frame-id (add-hook
'frame
(→ (gui/rect rect (aq 'frame *colorscheme*))
(when checked
(fill-rect checked-rect (aq 'frame *colorscheme*))))))
(unclick-id (add-hook
'unclick
(lambda (_ l r)
(when (or *click-can-be-handled*
*gui/checkbox-force-can-be-handled*)
(when (point-in-rect? (get-mouse-position) rect)
(set! checked (not checked))
(cb checked)))))))
(→ (delete-hook 'frame frame-id) (delete-hook 'unclick unclick-id))))
zostawia narysowany tekst. zwraca destruktor. argumenty
jak do (draw-text)
argumenty
(define (gui/draw-text-persist . args)
"zostawia narysowany tekst. zwraca destruktor. ***argumenty jak do `(draw-text)`***"
(let ((id (add-hook 'frame (→ (apply draw-text args)))))
(→ (delete-hook 'frame id))))
form pytający użytkownika o dane nowego źródła
(define (gui/new-source-form)
"form pytający użytkownika o dane nowego źródła"
(stop-simulation)
(set! *click-can-be-handled* #f)
(set! *keypress-can-be-handled* #f)
(set! *gui/slider-force-can-be-handled* #t)
(set! *gui/button-force-can-be-handled* #t)
(set! *gui/checkbox-force-can-be-handled* #t)
(set! *current-mode* 'new-source)
(define nb-or-thickness 1)
(define mouse-reactive #f)
(define angle 0)
(define default-light (aq 'default-light *colorscheme*))
(define color-r (list-ref default-light 0))
(define color-g (list-ref default-light 1))
(define color-b (list-ref default-light 2))
(define color-a 255)
(let* ((window-box-rect (list
gui/new-source-form:padding
gui/new-source-form:padding
(- *screen-width* (* 2 gui/new-source-form:padding))
(- *screen-height* (* 2 gui/new-source-form:padding))))
(window-box-data (gui/window-box-retained window-box-rect
"nowe źródło"))
(d-window-box (car window-box-data))
(rect (cadr window-box-data))
(d-n-beam-slider (gui/slider
(list (+ 10 (car rect)) (+ 10 (cadr rect)) 128 32)
1
20
(→1 (set! nb-or-thickness x))))
(d-n-beam-label (let ((id (add-hook
'frame
(→
(gui/draw-text
(string-append
(if (white?
(list color-r color-g color-b))
"szerokość wiązki (światło białe): "
"ilość wiązek: ")
(number->string nb-or-thickness))
(cons
(+ 10 (car rect) 128 10)
(+ 10
(cadr rect)
(/ (cdr (measure-text "A" 16)) 2)))
16
(aq 'font *colorscheme*))))))
(→ (delete-hook 'frame id))))
(_1-line-height (+ 10 (cadr rect) 32))
(d-mouse-r-checkbox (gui/checkbox
(list (+ (car rect) 10)
(+ 10 _1-line-height)
20
20)
(→1 (set! mouse-reactive x))
mouse-reactive))
(d-mouse-r-label (gui/draw-text-persist
"czy wiązka wskazuje na myszkę?"
(cons
(+ (car rect) 10 16 10)
(+ _1-line-height (/ (cdr (measure-text "A" 16)) 2)))
16
(aq 'font *colorscheme*)))
(_2-line-height (+ _1-line-height 32))
(d-angle-slider (gui/slider
(list (+ 10 (car rect)) (+ 10 _2-line-height) 128 32)
0
360
(→1 (set! angle (round x)))))
(d-angle-label (let ((id (add-hook
'frame
(→
(gui/draw-text
(string-append "kąt: "
(number->string angle))
(cons
(+ 10 (car rect) 128 10)
(+ 10
_2-line-height
(/ (cdr (measure-text "A" 16)) 2)))
16
(aq 'font *colorscheme*))))))
(→ (delete-hook 'frame id))))
(_3-line-height (+ _2-line-height 32 16))
(d-col-label (gui/draw-text-persist
"kolor"
(cons (+ 10 (car rect)) (+ 10 _3-line-height))
16
(aq 'font *colorscheme*)))
(d-r-slider (gui/slider
(list (+ 10 (car rect))
(+ 10 10 _3-line-height (cdr (measure-text "A" 16)))
128
32)
0
255
(→1 (set! color-r x))))
(d-g-slider (gui/slider
(list (+ 128 16 10 (car rect))
(+ 10 10 _3-line-height (cdr (measure-text "A" 16)))
128
32)
0
255
(→1 (set! color-g x))))
(d-b-slider (gui/slider
(list (+ 256 32 10 (car rect))
(+ 10 10 _3-line-height (cdr (measure-text "A" 16)))
128
32)
0
255
(→1 (set! color-b x))))
(_4-line-height (+ 32 10 10 _3-line-height (cdr (measure-text "A" 16))))
(d-color-fill (let ((id (add-hook
'frame
(→
(fill-rect
(list (+ 10 (car rect))
(+ 10 _4-line-height)
128
32)
(list color-r color-g color-b color-a))))))
(→ (delete-hook 'frame id))))
(d-ok-btn (car
(gui/btn
(cons (+ (car rect) 10) (- *screen-height* 80))
"Ok"
(→
(create-source
`((n-beams unquote nb-or-thickness)
(reactive unquote mouse-reactive)
(angle unquote angle)
(pos unquote gui/new-source-form:pos)
(color unquote (list color-r color-g color-b color-a))))
(d-window-box)
(d-n-beam-slider)
(d-n-beam-label)
(d-mouse-r-checkbox)
(d-mouse-r-label)
(d-angle-slider)
(d-angle-label)
(d-col-label)
(d-r-slider)
(d-g-slider)
(d-b-slider)
(d-color-fill)
(d-ok-btn)
(set! *click-can-be-handled* #t)
(set! *keypress-can-be-handled* #t)
(set! *gui/slider-force-can-be-handled* #f)
(set! *gui/button-force-can-be-handled* #f)
(set! *gui/checkbox-force-can-be-handled* #f)
(set! *current-mode* nil)
(start-simulation))))))
nil))
zwraca rect, który zmieści się na ekranie
argumenty
(define (gui/rect-fit-into-screen rect)
"zwraca `rect`, który zmieści się na ekranie"
(let ((x (list-ref rect 0))
(y (list-ref rect 1))
(w (list-ref rect 2))
(h (list-ref rect 3)))
(list (if (> (+ x w) *screen-width*)
(- x (abs (- *screen-width* (+ x w))))
x)
(if (> (+ y h) *screen-height*)
(- y (abs (- *screen-height* (+ y h))))
y)
w
h)))
argumenty
(define (gui/mp-slider+ok from to cb n-after-comma)
(set! *click-can-be-handled* #f)
(set! *gui/button-force-can-be-handled* #t)
(set! *gui/slider-force-can-be-handled* #t)
(when (eqv? *current-mode* nil)
(set! *current-mode* gui/mp-slider+ok:ident))
(when (eqv? *current-mode* 'selected)
(set! sel-mode:menu-open #t)
(set! sel-mode:wait-a-sec #t))
(define v from)
(let* ((mp (get-mouse-position))
(start-time (time))
(after-comma-dummy (apply string
(map (→ #\A)
(⍳ 0
1
(if (eqv? 0 n-after-comma)
0
(+ n-after-comma 1))))))
(max-text-size (measure-text
(string-append "Ok: "
(number->string to)
after-comma-dummy)
gui/button:text-size))
(rect (gui/rect-fit-into-screen (list (car mp) (cdr mp) 240 32)))
(sl-rect (list (list-ref rect 0)
(list-ref rect 1)
180
(list-ref rect 3)))
(real-cb (→1 (set! v (round-off x n-after-comma))
(set! *gui/button:skip-unclick* #t)
(cb x))))
(letrec ((slider-dest (gui/slider sl-rect from to real-cb))
(btn-dest (gui/button-textfn
(list (+ (car sl-rect) (caddr sl-rect) 16)
(+ (cadr sl-rect) 6)
(+ (* 2 gui/button:padding) (car max-text-size))
(+ (* 2 gui/button:padding) (cdr max-text-size)))
(→ (string-append "Ok: " (number->string v)))
(→ (when (> (time) start-time)
(set! *click-can-be-handled* #t)
(set! *gui/button-force-can-be-handled* #f)
(set! *gui/slider-force-can-be-handled* #f)
(when (eqv? *current-mode* gui/mp-slider+ok:ident)
(set! *current-mode* nil))
(when (eqv? *current-mode* 'selected)
(set! sel-mode:menu-open #f)
(set! sel-mode:wait-a-sec #f))
(slider-dest)
(btn-dest))))))
nil)))
(define (gui/show-window-opts)
(let* ((cb-dests (map (→1 (let ((nam (list-ref winopts-names x)))
(gui/checkbox (list 10 (+ 20 (* 30 x)) 22 22)
(lambda (v)
(set-window-flag (eval nam) v))
(get-window-flag (eval nam)))))
(⍳ 0 1 (length winopts-names))))
(frame-id (add-hook
'frame
(→
(for-each
(→1
(gui/draw-text
(symbol->string (list-ref winopts-names x))
(cons 40 (+ 20 (* 30 x)))
18
(aq 'font *colorscheme*)))
(⍳ 0 1 (length winopts-names)))))))
(→ (for-each (→1 (x)) cb-dests) (delete-hook 'frame frame-id))))
(define (gui/show-hook-status)
(let ((id (add-hook
'frame
(→
(for-each
(→1
(let* ((sym (list-ref *hookable* x))
(n (length (get-all-hooks sym))))
(draw-text
(string-append (symbol->string sym) " " (number->string n))
(cons 16 (- *screen-height* 64 (+ 10 (* x 20))))
16
white)))
(⍳ 0 1 (length *hookable*)))))))
(→ (delete-hook 'frame id))))
argumenty
(define (gui/show-fps pos)
(let* ((cur-fps 0)
(fps 0)
(frame-id (add-hook
'frame
(→
(draw-text (string-append "fps: " (number->string cur-fps))
pos
21
(aq 'font *colorscheme*))
(++ fps))))
(clock-id (add-hook 'clock (→ (set! cur-fps fps) (set! fps 0)))))
(→ (delete-hook 'frame frame-id) (delete-hook 'clock clock-id))))
(define (gui/save-current)
(gui/input-popup "podaj nazwę pliku" (→1 (serialize:save-to x)) #t))
(define (gui/load-example-menu)
(let ((opts (map
(→1
(let ((e (list-ref *examples* x)))
(cons (string-append (number->string (+ 1 x)) ". " (car e))
(cdr e))))
(⍳ 0 1 (length *examples*)))))
(gui/option-menu (get-mouse-position) opts)))
argumenty
(define (gui/change-source-color-form pos cb)
(set! *click-can-be-handled* #f)
(set! *gui/slider-force-can-be-handled* #t)
(set! *gui/button-force-can-be-handled* #t)
(define r 255)
(define g 255)
(define b 255)
(when (eqv? *current-mode* nil)
(set! *current-mode* gui/change-source-color-form:ident))
(when (eqv? *current-mode* 'selected)
(set! sel-mode:menu-open #t)
(set! sel-mode:wait-a-sec #t))
(let*
((w 128)
(el-h 32)
(user-rect (list (car pos) (cdr pos) w (* 4 el-h)))
(rect (gui/rect-fit-into-screen user-rect))
(call-cb (→ (cb (list r g b))))
(_ (call-cb))
(d-r-slider (gui/slider (list (car rect) (cadr rect) w el-h)
0
255
(→1 (set! r x) (call-cb))))
(d-g-slider (gui/slider (list (car rect) (+ (cadr rect) el-h) w el-h)
0
255
(→1 (set! g x) (call-cb))))
(d-b-slider (gui/slider (list (car rect) (+ (cadr rect) el-h el-h) w el-h)
0
255
(→1 (set! b x) (call-cb))))
(d-ok-btn
(car
(gui/btn
(cons (car rect) (+ (cadr rect) (* 3 el-h)))
"ok"
(→ (when (eqv? *current-mode* gui/change-source-color-form:ident)
(set! *current-mode* nil))
(when (eqv? *current-mode* 'selected)
(set! sel-mode:wait-a-sec #f)
(set! sel-mode:menu-open #f))
(set! *click-can-be-handled* #t)
(set! *gui/slider-force-can-be-handled* #f)
(set! *gui/button-force-can-be-handled* #f)
(d-r-slider)
(d-g-slider)
(d-b-slider)
(d-ok-btn)
(call-cb))))))))
zwraca wynik assq bez car
argumenty
(define (aq e alist)
"zwraca wynik assq bez car"
(args '((e . "element szukany") (alist . "lista asocjasyjna")))
(cdr (assq e alist)))
zwraca cdr dla l jeśli l to lista lub para
argumenty
(define (cdr* l)
"zwraca cdr dla l jeśli l to lista lub para"
(if (or (pair? l)
(list? l))
(cdr l)
l))
zwraca wynik (assq e alist) jeśli e istnieje w alist. w przeciwnym wypadku o
argumenty
(define (aq-or e alist o)
"zwraca wynik (assq e alist) jeśli e istnieje w alist. w przeciwnym wypadku o"
(let ((v (assq e alist)))
(if v
(cdr v)
o)))
wewnętrzna funkcja aktualizująca sources za każdym razem gdy zostaną zmienione
(define (update-sources)
"wewnętrzna funkcja aktualizująca *sources* za każdym razem gdy zostaną\n zmienione"
(set! *sources* (get-all-sources)))
tworzy nowe source_t (źródło światła)
argumenty
przykłady
(create-source '((x . 500) (y . 500) (reactive . #t))) →
tworzy reagujące na myszkę źródło na pozycji (500 500)
(define (create-source a)
"tworzy nowe source_t (źródło światła)"
(args
'((a . "lista asocjacyjna z elementami 'x, 'y, 'size, 'angle, 'thickness,\n 'reactive, 'color, 'n-beam.\n wszystkie elementy mają wartości domyślne i mogą być pominięte.\n zamiast 'x i 'y, może zostać zdefiniowane samo 'pos")))
(example '((create-source '((x . 500) (y . 500) (reactive . #t)))
"tworzy reagujące na myszkę źródło na pozycji (500 500)"))
(let* ((pos (aq-or 'pos a `(,(aq-or 'x a 100) unquote (aq-or 'y a 100))))
(x (car pos))
(y (cdr pos))
(size (aq-or 'size a 20))
(ang (aq-or 'angle a 90))
(thickness (aq-or 'thickness a 1))
(reactive (aq-or 'reactive a #t))
(n-beams (aq-or 'n-beams a 1))
(color (aq-or 'color a (aq 'default-light *colorscheme*)))
(id (real-create-source x y size ang thickness reactive n-beams color)))
(update-sources)
(cons 'source id)))
rysuje linię od pt1 do pt2 o grubości thick i kolorze color
argumenty
(define (draw-line pt1 pt2 thick color)
"rysuje linię od pt1 do pt2 o grubości thick i kolorze color"
(args '((pt1 . "punkt 1 (x . y)") (pt2 . "punkt 2 (x . y)")
(thick . "grubość")
(color . "kolor (r g b a)")))
(let ((x1 (car pt1))
(y1 (cdr pt1))
(x2 (car pt2))
(y2 (cdr pt2)))
(real-draw-line x1 y1 x2 y2 thick color)))
aktualizuje źródło o id n ustawiając wszystkie jego wartości. lepiej używać set-source-e!
argumenty
(define (set-source! n x y ang thickness mouse-reactive n-beams color)
"aktualizuje źródło o id n ustawiając wszystkie jego wartości. lepiej używać set-source-e!"
(real-set-source! n x y ang thickness mouse-reactive n-beams color)
(update-sources))
aktualizuje właściwość sym na v w źródle o id n
argumenty
(define (set-source-e! n sym v)
"aktualizuje właściwość sym na v w źródle o id n"
(args
'((n . "id źródła")
(sym . "'pos | 'angle | 'thickness | 'color | 'mouse-reactive | 'n-beams w zależności od tego co chcemy zmienić")
(v . "nowa wartość dla sym")))
(when (eqv? sym 'thickness)
(print "setting thickness to" v))
(if (> n (length *sources*))
#f
(let* ((src (get-source n))
(x (if (eq? 'pos sym)
(car v)
(car (list-ref src 0))))
(y (if (eq? 'pos sym)
(cdr v)
(cdr (list-ref src 0))))
(ang (if (eq? 'angle sym)
v
(list-ref src 1)))
(thickness (if (eq? 'thickness sym)
v
(list-ref src 2)))
(mouse-reactive (if (eq? 'mouse-reactive sym)
v
(list-ref src 3)))
(n-beams (if (eq? 'n-beams sym)
v
(list-ref src 4)))
(color (if (eq? 'color sym)
v
(list-ref src 5))))
(set-source! n x y ang thickness mouse-reactive n-beams color)))
(update-sources))
argumenty
'pt | 'vert-len | 'nt(define (set-prism-e! id t v)
(args '((t . "`'pt` | `'vert-len` | `'n`") (v . "wartość dla `t`")))
(let* ((prism (cdr (assv id *prisms*)))
(pt (if (eqv? t 'pt)
v
(list-ref prism 0)))
(vert-len (if (eqv? t 'vert-len)
v
(list-ref prism 4)))
(n (if (eqv? t 'n)
v
(list-ref prism 5))))
(set-prism! id pt vert-len n)))
argumenty
r | center | d(define (set-lens-e! id t v)
(args '((t . "`r | center | d`")))
(let* ((lens (get-bounceable id))
(r (if (eqv? t 'r)
v
(list-ref lens 3)))
(center (if (eqv? t 'center)
v
(list-ref lens 4)))
(d (if (eqv? t 'd)
v
(list-ref lens 5))))
(set-lens! id center d r)))
zwraca (w . h) tekstu text o wielkości size i spacingu spacing (jeśli podany)
argumenty
(define (measure-text text size . spacing)
"zwraca (w . h) tekstu text o wielkości size i spacingu spacing (jeśli podany)"
(let ((spacing (if (null? spacing)
*default-spacing*
(car spacing))))
(real-measure-text text size spacing)))
wypisuje tekst text domyślnym fontem na pozycji pos, o wielkości sz i kolorze color. można też podać spacing.
argumenty
(define (draw-text text pos sz color . spacing)
"wypisuje tekst text domyślnym fontem na pozycji pos, o wielkości sz i kolorze\n color. można też podać spacing."
(args '((color . "w postaci (r g b a)")))
(let ((x (car pos))
(y (cdr pos))
(spc (if (null? spacing)
*default-spacing*
(car spacing))))
(real-draw-text text x y sz spc color)))
robi TraceLog z typem T i tekstem vs
argumenty
'trace | 'debug | 'info | 'warning | 'error | 'fatal)(define (tracelog t . vs)
"robi TraceLog z typem T i tekstem vs"
(args
'((t . "typ logu (moze być `'trace | 'debug | 'info | 'warning | 'error | 'fatal`)")
(vs . "tekst")))
(let ((type (if (number? t)
t
(cond
((eqv? t 'trace)
log-trace)
((eqv? t 'debug)
log-debug)
((eqv? t 'info)
log-info)
((eqv? t 'warning)
log-warning)
((eqv? t 'error)
log-error)
((eqv? t 'fatal)
log-fatal)))))
(real-tracelog type (->string vs))))
tworzy nowy obiekt w obrębie poly-points rysowany co
klatkę przez draw-function, jeśli wiązka światła napotka
obiekt, przemieniana jest wg. light-remap-function. więcej
doc TBD
argumenty
(define (register-custom poly-points draw-function light-remap-function)
"tworzy nowy obiekt w obrębie `poly-points` rysowany co klatkę przez `draw-function`, jeśli wiązka światła napotka obiekt, przemieniana jest wg. `light-remap-function`. więcej doc TBD"
(set! *all-custom-fns*
(append *all-custom-fns* (list (cons draw-function light-remap-function))))
(let ((l (last *all-custom-fns*)))
(apply real-register-custom (list poly-points (car l) (cdr l)))))
w przyszłości będzie dodawała hooki które mogą być blokowane przez systemowe
argumenty
(define (add-user-hook s f)
"w przyszłości będzie dodawała hooki które mogą być blokowane przez systemowe"
(set! *all-hooks* (append *all-hooks* (list f)))
(real-add-hook s (last *all-hooks*)))
zatrzymuje wszystko (przestaje renderować)
(define (stop-simulation)
"zatrzymuje wszystko (przestaje renderować)"
(let* ((conf (get-winconf))
(next-conf (map (→1 (if (eqv? x 2)
__state_stopped
(list-ref conf x)))
(⍳ 0 1 (length conf)))))
(apply set-winconf next-conf)))
odpala z powrotem wszystko (zaczyna renderować)
(define (start-simulation)
"odpala z powrotem wszystko (zaczyna renderować)"
(let* ((conf (get-winconf))
(next-conf (map (→1 (if (eqv? x 2)
__state_running
(list-ref conf x)))
(⍳ 0 1 (length conf)))))
(apply set-winconf next-conf)))
argumenty
(define (fill-rect rect color)
(let ((x (car rect))
(y (cadr rect))
(w (caddr rect))
(h (cadddr rect)))
(real-fill-rect x y w h color)))
(define (experimental/toggle-resizable)
(set-window-flag flag-window-resizable
(not (get-window-flag flag-window-resizable))))
wywołuje create-mirror, tylko, że argumenty to punkty w
parach
argumenty
(define (add-mirror p1 p2)
"wywołuje `create-mirror`, tylko, że argumenty to punkty w parach"
(args '((p1 . "'(x . y)") (p2 . "'(x . y)")))
(create-mirror (car p1) (cdr p1) (car p2) (cdr p2)))
(define (delete-all-sources)
(real-delete-all-sources)
(update-sources))
argumenty
(define (delete-source id)
(let* ((sources-kept (map
(→1 (list-ref *sources* x))
(filter (→1 (not (eqv? id x)))
(⍳ 0 1 (length *sources*)))))
(sources-sexps (map serialize:source->sexp sources-kept)))
(delete-all-sources)
(for-each eval sources-sexps)))
argumenty
(define (delete-sources lst)
(let* ((sources-kept (map
(→1 (list-ref *sources* x))
(filter (→1 (not (memv x lst)))
(⍳ 0 1 (length *sources*)))))
(sources-sexps (map serialize:source->sexp sources-kept)))
(delete-all-sources)
(for-each eval sources-sexps)))
argumenty
(define (sel-mode:highlight-rects rects sel-map)
(for-each (→1 (gui/rect (list-ref rects x)
(if (list-ref sel-map x)
(aq 'green *colorscheme*)
(aq 'red *colorscheme*))))
(⍳ 0 1 (length rects))))
(define (sel-mode:get-menu)
(cond
((> (length sel-mode:selected-source-ids) 0)
(if (eqv? (length sel-mode:selected-bounceable-ids) 0)
(option-menu-for 'source sel-mode:selected-source-ids)
sel-mode:default-menu))
((eqv? (id->btype (car sel-mode:selected-bounceable-ids)) 'mirror)
sel-mode:default-menu)
((all-same? (map id->btype sel-mode:selected-bounceable-ids))
(option-menu-for (id->btype (car sel-mode:selected-bounceable-ids))
sel-mode:selected-bounceable-ids))
(else
sel-mode:default-menu)))
(define (start-selected-mode)
(set! *current-mode* 'selected)
(if (> (+ (length sel-mode:selected-bounceable-ids)
(length sel-mode:selected-source-ids))
0)
(let*
((mp (get-mouse-position))
(sel-mode:menu-open #f)
(rects
(map
normalize-rectangle
(append
(map thing->rect (map get-bounceable sel-mode:selected-bounceable-ids))
(map (→1 (src->rect (car (list-ref *sources* x))))
sel-mode:selected-source-ids))))
(minx (minl (map car rects)))
(miny (minl (map cadr rects)))
(maxx (maxl (map (→1 (+ (car x) (caddr x))) rects)))
(maxy (maxl (map (→1 (+ (cadr x) (cadddr x))) rects)))
(∆x 0)
(∆y 0)
(∆mouse nil)
(bounding-rect nil)
(update-bounding-rect
(→ (set! bounding-rect
(list (+ ∆x minx) (+ ∆y miny) (- maxx minx) (- maxy miny)))))
(_ (update-bounding-rect))
(b-rect-id
(add-hook 'frame (→ (gui/rect bounding-rect (aq 'red *colorscheme*)))))
(delete-handler-id
(add-hook
'keypress
(→2 (when (and (not sel-mode:menu-open)
(not sel-mode:wait-a-sec)
(eqv? y 261))
(for-each delete-bounceable sel-mode:selected-bounceable-ids)
(delete-sources sel-mode:selected-source-ids)
(end-selected-mode)))))
(cursor-handler-id
(add-hook 'frame
(→ (when (and (not sel-mode:menu-open)
(not sel-mode:wait-a-sec))
(if (point-in-rect? (get-mouse-position) bounding-rect)
(set-cursor mouse-cursor-resize-all)
(set-cursor mouse-cursor-arrow))))))
(external-close-handler-id
(add-hook 'frame
(→ (when sel-mode:should-end-selected-mode
(end-selected-mode)))))
(move-handler-id
(add-hook
'click
(lambda (first l r)
(let ((mp (get-mouse-position)))
(when (and (not sel-mode:menu-open)
(not sel-mode:wait-a-sec))
(when l
(when first
(set! ∆mouse (cons (- (car mp) minx ∆x) (- (cdr mp) miny ∆y))))
(let ((∆last (cons ∆x ∆y)))
(set! ∆x (- (car mp) minx (car ∆mouse)))
(set! ∆y (- (cdr mp) miny (cdr ∆mouse)))
(for-each
(→1 (reposition-source-by-delta
x
(cons (- ∆x (car ∆last)) (- ∆y (cdr ∆last)))))
sel-mode:selected-source-ids)
(for-each
(→1 (reposition-bounceable-by-delta
x
(cons (- ∆x (car ∆last)) (- ∆y (cdr ∆last)))))
sel-mode:selected-bounceable-ids))
(update-bounding-rect)))))))
(menu-handler-id
(add-hook 'click
(lambda (first l r)
(when (and first
r
(not sel-mode:menu-open)
(not sel-mode:wait-a-sec))
(set! sel-mode:menu-open #t)
(set! *gui/option-menu-force-can-be-handled* #t)
(gui/option-menu (get-mouse-position)
(sel-mode:get-menu)
(→ (set! sel-mode:menu-open #f)))))))
(end-selected-mode (→ (delete-hook 'frame b-rect-id)
(delete-hook 'frame external-close-handler-id)
(delete-hook 'frame cursor-handler-id)
(delete-hook 'click move-handler-id)
(delete-hook 'click menu-handler-id)
(delete-hook 'click close-handler-id)
(delete-hook 'keypress delete-handler-id)
(really-end-selected-mode)))
(close-handler-id
(add-hook
'click
(lambda (first l r)
(when (and (not sel-mode:menu-open)
(not sel-mode:wait-a-sec))
(when (and first
l
(not (point-in-rect? (get-mouse-position) bounding-rect)))
(end-selected-mode))))))))
(really-end-selected-mode)))
(define (really-end-selected-mode)
(set! sel-mode:menu-open #f)
(set! sel-mode:should-end-selected-mode #f)
(set! sel-mode:wait-a-sec #f)
(set! *gui/option-menu-force-can-be-handled* #f)
(set! sel-mode:last-time
(if (> (+ (length sel-mode:selected-bounceable-ids)
(length sel-mode:selected-source-ids))
0)
(time)
0))
(set! *click-can-be-handled* #t)
(set! *current-mode* nil))
argumenty
(define (serialize:bounceable->sexp b)
(let ((type (car b)))
(cond
((eqv? type 'mirror)
`(add-mirror ',(list-ref b 1) ',(list-ref b 2)))
((eqv? type 'prism)
`(create-prism ',(list-ref b 1) ,(list-ref b 5) ,(list-ref b 6)))
((eqv? type 'lens)
`(create-lens ',(list-ref b 4) ,(list-ref b 5) ,(list-ref b 3)))
(else
(error "unsupported type: " type)))))
argumenty
(define (serialize:source->sexp s)
(let ((pt (list-ref s 0))
(angle (list-ref s 1))
(thickness (list-ref s 2))
(reactive (list-ref s 3))
(n-beams (list-ref s 4))
(color (list-ref s 5)))
`(create-source '((pos unquote pt) (angle unquote angle)
(thickness unquote thickness)
(reactive unquote reactive)
(n-beams unquote n-beams)
(color unquote color)))))
argumenty
(define (serialize:print sexp)
(display sexp)
(newline))
argumenty
(define (serialize:save-to filename)
(with-output-to-file
filename
(→ (for-each serialize:print
(map serialize:bounceable->sexp (get-all-bounceables)))
(for-each serialize:print (map serialize:source->sexp *sources*))))
(tracelog 'info (string-append "saved to " filename)))
argumenty
(define (serialize:read-sexps f acc)
(let ((sexp (read f)))
(cond
((eof-object? sexp)
acc)
(else
(serialize:read-sexps f (append acc (list sexp)))))))
argumenty
(define (reposition-source-hook first left right)
(when (or *click-can-be-handled*
repositioning-source)
(let ((mp (get-mouse-position)))
(when (and first
left)
(for-each (lambda (n)
(let* ((s (list-ref *sources* n))
(x (- (caar s) *source-size*))
(y (- (cdr (car s)) *source-size*)))
(when (point-in-rect? mp
(list (+ x (/ *source-size* 2))
(+ y (/ *source-size* 2))
*source-size*
*source-size*))
(set-cursor mouse-cursor-resize-all)
(set! *click-can-be-handled* #f)
(set! *current-click-handler* 'reposition-source-hook)
(set! repositioning-dx (- (car mp) x *source-size*))
(set! repositioning-dy (- (cdr mp) y *source-size*))
(set! repositioning-source n))))
(iota 0 1 (length *sources*))))
(when (and (not first)
repositioning-source)
(let ((pos (cons (- (car mp) repositioning-dx)
(- (cdr mp) repositioning-dy))))
(set-source-e! repositioning-source 'pos pos))))))
argumenty
(define (reposition-source-end-hook first left right)
(when repositioning-source
(set-cursor mouse-cursor-default)
(set! *click-can-be-handled* #t)
(set! repositioning-source #f)))
argumenty
(define (start-drawing-mirror-hook first left right)
(when (and (eqv? *current-mode* 'mirror-drawing)
(or *click-can-be-handled*
drawing-new-mirror)
(not right))
(set! *click-can-be-handled* #f)
(set! *current-click-handler* 'start-drawing-mirror-hook)
(when (and first
left)
(set! drawing-new-mirror #t)
(set! mirror-last-x (car (get-mouse-position)))
(set! mirror-last-y (cdr (get-mouse-position))))
(when (and (not first)
drawing-new-mirror)
(draw-line `(,mirror-last-x unquote mirror-last-y)
`(,(car (get-mouse-position)) unquote (cdr (get-mouse-position)))
2
(aq 'drawing-new-mirror *colorscheme*)))))
argumenty
(define (end-drawing-mirror-hook first left right)
(when drawing-new-mirror
(set-cursor mouse-cursor-default)
(set! *click-can-be-handled* #t)
(set! drawing-new-mirror #f)
(set! *current-mode* nil)
(create-mirror mirror-last-x
mirror-last-y
(car (get-mouse-position))
(cdr (get-mouse-position)))))
handler dla funkcji (wait)
argumenty
(define (wait-handler time)
"handler dla funkcji `(wait)`"
(for-each (→1 ((cdr x))) (filter (→1 (<= (car x) time)) *wait-alist*))
(set! *wait-alist* (filter (→1 (not (<= (car x) time))) *wait-alist*)))
(define (create-source-at-mouse-position)
(create-source `((pos unquote (get-mouse-position)) (reactive . #f))))
argumenty
(define (keypress-default-hook c _)
(when *keypress-can-be-handled*
(let* ((mp (get-mouse-position)))
(cond
((eqv? c #\A)
(create-source-at-mouse-position))
((eqv? c #\e)
(letrec
((id
(add-hook
'frame
(→ (gui/input-popup "eval scheme" loads) (delete-hook 'frame id)))))))
((eqv? c #\`)
(if (null? fps-dest)
(begin
(set! fps-dest (gui/show-fps '(16 . 16)))
(set! hook-status-dest (gui/show-hook-status)))
(begin
(hook-status-dest)
(fps-dest)
(set! hook-status-dest nil)
(set! fps-dest nil))))
((eqv? c #\R)
(experimental/toggle-resizable))
((eqv? c #\M)
(toggle-mode-display))
((eqv? c #\~)
(if (null? window-opts-dest)
(set! window-opts-dest (gui/show-window-opts))
(begin
(window-opts-dest)
(set! window-opts-dest nil))))
((eqv? c #\q)
(exit 0))))))
argumenty
(define (src->rect pos)
(list (- (car pos) (/ *source-size* 2))
(- (cdr pos) (/ *source-size* 2))
*source-size*
*source-size*))
argumenty
(define (option-menu-for-lens ids)
`(("zmień r" unquote
(→ (gui/mp-slider+ok 5
200.0
(lambda (v)
(map (→1 (set-lens-e! x 'r v)) ids))
1)))
("zmień d" unquote
(→ (gui/mp-slider+ok 5
200.0
(lambda (v)
(map (→1 (set-lens-e! x 'd v)) ids))
0)))
("kopiuj"
unquote
(→
(set! *clipboard*
(map (→1 (serialize:bounceable->sexp (get-bounceable x))) ids))))
("usuń" unquote
(→ (for-each delete-bounceable ids)
(when (eqv? *current-mode* 'selected)
(set! sel-mode:should-end-selected-mode #t))))))
argumenty
(define (option-menu-for-prism ids)
`(("zmień współczynnik załamania pryzmatu"
unquote
(→ (gui/mp-slider+ok 1.0
2.0
(lambda (v)
(map (→1 (set-prism-e! x 'n v)) ids))
3)))
("zmień wielkość boku"
unquote
(→ (gui/mp-slider+ok 1
500
(lambda (v)
(map (→1 (set-prism-e! x 'vert-len v)) ids))
0)))
("kopiuj"
unquote
(→
(set! *clipboard*
(map (→1 (serialize:bounceable->sexp (get-bounceable x))) ids))))
("usuń" unquote
(→ (for-each delete-bounceable ids)
(when (eqv? *current-mode* 'selected)
(set! sel-mode:should-end-selected-mode #t))))))
argumenty
(define (option-menu-for-source ids)
(append
`(("zmień kąt"
unquote
(→
(gui/mp-slider+ok
0
359
(lambda (v)
(map
(→1 (set-source-e! x 'mouse-reactive #f) (set-source-e! x 'angle v))
ids))
0)))
("zmień kolor"
unquote
(→
(gui/change-source-color-form
(get-mouse-position)
(lambda (v)
(map (→1 (set-source-e! x 'color v)) ids)))))
("'mouse-reactive"
unquote
(→
(map
(→1
(set-source-e! x
'mouse-reactive
(not (list-ref (list-ref *sources* x) 3))))
ids))))
(if (all (→1 (white? (list-ref (list-ref *sources* x) 5))) ids)
`(("zmień szerokość wiązki"
unquote
(→ (gui/mp-slider+ok 1
10
(lambda (v)
(map (→1 (set-source-e! x 'n-beams v)) ids))
0))))
'())
(if (all (→1 (not (white? (list-ref (list-ref *sources* x) 5)))) ids)
`(("zmień ilość wiązek"
unquote
(→ (gui/mp-slider+ok 0
*source-size*
(lambda (v)
(map (→1 (set-source-e! x 'n-beams v)) ids))
0))))
'())
`(("kopiuj"
unquote
(→
(set! *clipboard*
(map (→1 (serialize:source->sexp (list-ref *sources* x))) ids))))
("usuń" unquote
(→ (delete-sources ids)
(when (eqv? *current-mode* 'selected)
(set! sel-mode:should-end-selected-mode #t)))))))
argumenty
(define (option-menu-for t id-or-ids)
(let ((ids (if (list? id-or-ids)
id-or-ids
(list id-or-ids))))
(if (memv t '(source prism lens))
(let* ((f-name (string->symbol
(string-append "option-menu-for-" (symbol->string t))))
(f (eval f-name)))
(f ids))
(error "option-menu-for: unknown T: " t))))
argumenty
(define (_open-menu vs)
(set! *click-can-be-handled* #f)
(set! *gui/option-menu-force-can-be-handled*)
(gui/option-menu (get-mouse-position)
vs
(→ (set! *click-can-be-handled* #t))))
ale fajna funkcja ciekawe jak dziala :333
(define (display-next-log)
"ale fajna funkcja ciekawe jak dziala :333"
(if (> (length *tracelog-queue*) 0)
(let* ((tl (car *tracelog-queue*))
(s (string-append "["
(number->string (aq 'time tl))
"] "
(symbol->string (aq 'type tl))
": "
(aq 's tl)))
(id (add-hook
'frame
(→
(draw-text s
'(0 . 0)
16
(aq 'font *colorscheme*)
*default-spacing*)))))
(set! *tracelog-queue* (cdr *tracelog-queue*))
(wait 2 (→ (delete-hook 'frame id) (display-next-log))))
(letrec ((id (add-hook 'log (→2 (display-next-log) (delete-hook 'log id)))))
nil)))
sprawdza czy dwa r1 i r2 mają punkty
wspólne. zwraca #f | #t
argumenty
(define (rect-collision? r1 r2)
"sprawdza czy dwa `r1` i `r2` mają punkty wspólne. zwraca `#f | #t`"
(not (eqv? (sum (rect-collision r1 r2)) 0.0)))
argumenty
(define (triangle->rect p1 p2 p3)
(let* ((x1 (car p1))
(y1 (cdr p1))
(x2 (car p2))
(y2 (cdr p2))
(x3 (car p3))
(y3 (cdr p3))
(a (- (max x1 x2 x3) (min x1 x2 x3)))
(h (* a (sqrt 3) 0.5)))
(list (min x1 x2 x3) (min y1 y2 y3) a h)))
argumenty
(define (prism->ptlist p)
(list (list-ref p 2) (list-ref p 3) (list-ref p 4)))
argumenty
(define (reposition-source-by-delta id ∆)
(let ((pos (car (list-ref *sources* id))))
(set-source-e! id
'pos
(cons (+ (car pos) (car ∆)) (+ (cdr pos) (cdr ∆))))))
argumenty
(define (reposition-mirror-by-delta id ∆)
(let* ((mirror (get-bounceable id))
(p1 (cadr mirror))
(p2 (caddr mirror))
(p1-new (cons (+ (car p1) (car ∆)) (+ (cdr p1) (cdr ∆))))
(p2-new (cons (+ (car p2) (car ∆)) (+ (cdr p2) (cdr ∆)))))
(set-mirror! id p1-new p2-new)))
argumenty
(define (reposition-prism-by-delta id ∆)
(let* ((prism (get-bounceable id))
(center (cadr prism))
(center-new (cons (+ (car center) (car ∆))
(+ (cdr center) (cdr ∆))))
(vert-len (list-ref prism 5))
(n (list-ref prism 6)))
(set-prism! id center-new vert-len n)))
argumenty
(define (reposition-lens-by-delta id ∆)
(let* ((lens (get-bounceable id))
(r (list-ref lens 3))
(center (list-ref lens 4))
(d (list-ref lens 5)))
(set-lens! id
(cons (+ (car center) (car ∆)) (+ (cdr center) (cdr ∆)))
d
r)))
argumenty
(define (reposition-bounceable-by-delta id ∆)
(let* ((thing (get-bounceable id))
(type (car thing)))
(cond
((eqv? type 'mirror)
(reposition-mirror-by-delta id ∆))
((eqv? type 'prism)
(reposition-prism-by-delta id ∆))
((eqv? type 'lens)
(reposition-lens-by-delta id ∆))
(else
(error (string-append (->string type) " unsupported"))))))
argumenty
(define (lens->rect lens)
(let* ((p1 (list-ref lens 1))
(p2 (list-ref lens 2))
(d (list-ref lens 5)))
(list (- (car p1) (/ d 2)) (cdr p1) d (- (cdr p2) (cdr p1)))))
argumenty
(define (thing->rect thing)
(let ((type (car thing)))
(cond
((eqv? type 'mirror)
(pts->rect (cadr thing) (caddr thing)))
((eqv? type 'prism)
(apply triangle->rect (prism->ptlist thing)))
((eqv? type 'lens)
(lens->rect thing))
(else
(error (string-append "thing->rect: unsupported" (->string thing)))))))
argumenty
(define (update-toplist l id)
(eval `(set! ,l
(map (→1 (if (eqv? (car x) ,id)
(append (list ,id) (cdr (get-bounceable ,id)))
x))
,l))))
argumenty
(define (add-bounceable-to-toplist l id)
(eval
`(set! ,l (append ,l (list (append (list ,id) (cdr (get-bounceable ,id))))))))
argumenty
(define (delete-from-toplist l id)
(eval `(set! ,l (filter (→1 (not (eqv? (car x) ,id))) ,l))))
(define (toggle-mode-display)
(set! *mode-display-on* (not *mode-display-on*)))
argumenty
(define (load-files-handler . vs)
(for-each load vs))
wypisuje argumenty do konsoli
argumenty
(define (print s . l)
"wypisuje argumenty do konsoli"
(for-each (lambda (v)
(display v)
(display " "))
(append (list s) l))
(newline))
wypisuje argumenty do konsoli, bez spacji poiędzy
argumenty
(define (pprint s . l)
"wypisuje argumenty do konsoli, bez spacji poiędzy"
(for-each display (append (list s) l))
(newline))
zwraca większą wartość pomiędzy a, a b
argumenty
(define (max2 a b)
"zwraca większą wartość pomiędzy a, a b"
(if (> a b)
a
b))
zwraca mniejszą wartość pomiędzy a, a b
argumenty
(define (min2 a b)
"zwraca mniejszą wartość pomiędzy a, a b"
(if (< a b)
a
b))
zwraca największą wartość pośród argumentów
argumenty
przykłady
(max 1 2 3) → 3
(define (max . ns)
"zwraca największą wartość pośród argumentów"
(example '((max 1 2 3) 3))
(foldr max2 (car ns) ns))
zwraca najmniejszą wartość pośród argumentów
argumenty
przykłady
(min 1 2 3) → 1
(define (min . ns)
"zwraca najmniejszą wartość pośród argumentów"
(example '((min 1 2 3) 1))
(foldr min2 (car ns) ns))
zwraca największą wartość z listy
argumenty
przykłady
(max '(1 2 3)) → 3
(define (maxl lst)
"zwraca największą wartość z listy"
(example '((max '(1 2 3)) 3))
(apply max lst))
zwraca najmniejszą wartość z listy
argumenty
przykłady
(min '(1 2 3)) → 1
(define (minl lst)
"zwraca najmniejszą wartość z listy"
(example '((min '(1 2 3)) 1))
(apply min lst))
argumenty
(define (bool->string v)
(if v
"#t"
"#f"))
zamienia cokolwiek na string
argumenty
(define (->string x)
"zamienia cokolwiek na string"
(cond
((list? x)
(foldr string-append
""
(map (lambda (x)
(string-append (->string x) " "))
x)))
((pair? x)
(string-append (->string (car x)) " " (->string (cdr x)) " "))
((number? x)
(number->string x))
((symbol? x)
(symbol->string x))
((boolean? x)
(bool->string x))
((char? x)
(string x))
((string? x)
x)
(else
"???")))
zamienia cokolwiek na znak
argumenty
(define (->char x)
"zamienia cokolwiek na znak"
(cond
((number? x)
(->char (number->string x)))
((string? x)
(car (string->list x)))
((char? x)
x)
(else
(error "->char: unexpected type"))))
tnie str na każdym napodkanym c
argumenty
przykłady
(string-split "abc|def|ghi" "|") → (abc def
ghi)
(define (string-split str c)
"tnie *str* na każdym napodkanym *c*"
(example '((string-split "abc|def|ghi" "|") ("abc" "def" "ghi")))
(let ((end (string-length str))
(ch (->char c)))
(let lp ((from 0)
(to 0)
(res '()))
(cond
((>= to end)
(reverse (if (> to from)
(cons (substring str from to) res)
res)))
((eqv? ch (string-ref str to))
(lp (+ to 1) (+ to 1) (cons (substring str from to) res)))
(else
(lp from (+ to 1) res))))))
wywołuje f dla każdego elementu z lst i zwraca listę elementów w których f zwraca #t (lub inną nie-#f wartość)
argumenty
przykłady
(filter (lambda (v) (eq? 1 v)) '(1 2 3 1 2 5)) → (1
1)
(define (filter f lst)
"wywołuje f dla każdego elementu z lst i zwraca listę elementów w których f zwraca #t (lub inną nie-#f wartość)"
(example '((filter (lambda (v)
(eq? 1 v))
'(1 2 3 1 2 5))
(1 1)))
(cond
((null? lst)
'())
((f (car lst))
(cons (car lst) (filter f (cdr lst))))
(else
(filter f (cdr lst)))))
zamienia zagnieżdżone listy w lst na jedną listę
argumenty
przykłady
(flatten '(1 (2) ((3)) ((((4)))))) → (1 2 3
4)
(define (flatten lst)
"zamienia zagnieżdżone listy w lst na jedną listę"
(example '((flatten '(1 (2) ((3)) ((((4)))))) (1 2 3 4)))
(let loop ((lst lst)
(acc '()))
(cond
((null? lst)
acc)
((pair? lst)
(loop (car lst) (loop (cdr lst) acc)))
(else
(cons lst acc)))))
uruchamia system, wcześniej zamieniając argumenty na
jeden string
argumenty
(define (sys . l)
"uruchamia `system`, wcześniej zamieniając argumenty na jeden string"
(system (apply string-append
(map (lambda (v)
(string-append (->string v) " "))
l))))
generuje ciąg liczb od d do e zwiększający się o step
argumenty
(define (iota s step e)
"generuje ciąg liczb od *d* do *e* zwiększający się o *step*"
(letrec ((i (lambda (s step e acc)
(cond
((>= s e)
acc)
(else
(i (+ s step) step e (append acc (list s))))))))
(i s step e '())))
sumuje wartości listy l
argumenty
(define (sum l)
"sumuje wartości listy *l*"
(apply + l))
sprawdza czy punkt jest w prostokącie
argumenty
(define (point-in-rect? pt rect)
"sprawdza czy punkt jest w prostokącie"
(args
'((pt . "punkt w postaci (x . y)") (rect . "prostokąt w postaci (x y w h)")))
(let ((px (car pt))
(py (cdr pt))
(rx (list-ref rect 0))
(ry (list-ref rect 1))
(rw (list-ref rect 2))
(rh (list-ref rect 3)))
(and (>= px rx)
(<= px (+ rx rw))
(>= py ry)
(<= py (+ ry rh)))))
dzieli listę lst co n elementów
argumenty
(define (split-every lst n)
"dzieli listę *lst* co *n* elementów"
(letrec ((f (lambda (in ret acc)
(cond
((null? in)
(if (null? acc)
ret
(append ret (list acc))))
((eqv? (length acc) n)
(f in (append ret (list acc)) '()))
(else
(f (cdr in) ret (append acc (list (car in)))))))))
(f lst '() '())))
wykonuje f po upłynięciu secs sekund
argumenty
(define (wait secs f)
"wykonuje `f` po upłynięciu `secs` sekund"
(set! *wait-alist* (append *wait-alist* `((,(+ (time) secs) unquote f)))))
zwraca ostatni element listy
argumenty
przykłady
(last '(a b c d)) → d
(define (last lst)
"zwraca ostatni element listy"
(example '((last '(a b c d)) d))
(cond
((null? lst)
nil)
((null? (cdr lst))
(car lst))
(else
(last (cdr lst)))))
zwraca średnią z listy
argumenty
(define (avg l)
"zwraca średnią z listy"
(/ (sum l) (length l)))
argumenty
(define (true? v)
v)
argumenty
(define (pts->rect p1 p2)
(list (car p1) (cdr p1) (- (car p2) (car p1)) (- (cdr p2) (cdr p1))))
zamienia prostokąt na listę punktów
argumenty
(define (rect->poly rect)
"zamienia prostokąt na listę punktów"
(let ((x (list-ref rect 0))
(y (list-ref rect 1))
(w (list-ref rect 2))
(h (list-ref rect 3)))
(list (cons x y) (cons (+ x w) y) (cons (+ x w) (+ y h)) (cons x (+ y h)))))
argumenty
(define (round-off-zero v)
(string->number (car (string-split (number->string v) "."))))
argumenty
przykłady
(round-off 10.1234123 2) → 10.12
(define (round-off z n)
(example '((round-off 10.1234123 2) 10.12))
(if (eqv? n 0)
(round-off-zero z)
(let ((power (expt 10 n)))
(/ (round (* power z)) power))))
argumenty
(define (get-lens-f r)
(/ 1.0 (+ (/ 1.0 r) (/ 1.0 r))))
(define (get-all-bounceables)
(append (map (→1 (append '(mirror) (cdr x))) *mirrors*)
(map (→1 (append '(custom) (cdr x))) *customs*)
(map (→1 (append '(prism) (cdr x))) *prisms*)
(map (→1 (append '(lens) (cdr x))) *lenss*)))
argumenty
(define (id->btype id)
(cond
((assq id *mirrors*)
'mirror)
((assv id *lenss*)
'lens)
((assv id *prisms*)
'prism)
((assv id *customs*)
'custom)
(else
#f)))
argumenty
(define (all f lst)
(or (null? lst)
(and (f (car lst))
(all f (cdr lst)))))
argumenty
(define (all-same? l)
(or (null? l)
(all (→1 (eqv? (car l) x)) l)))