SuperKamiGuru/foss-mmo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Splat a bunch of modules from elsewhere.

Browse source
This commit is contained in:
David Thompson 2024-05-17 17:49:43 -04:00
parent 7d728559d0
commit 1b950264d1
11 changed files with 3861 additions and 376 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
game.js
View file

@ -1,6 +1,7 @@
window.addEventListener("load", async () => {
try {
await Scheme.load_main("game.wasm", {}, {
await Scheme.load_main("game.wasm", {
user_imports: {
window: {
get: () => window,
innerWidth: () => window.innerWidth,
@ -67,6 +68,7 @@ window.addEventListener("load", async () => {
math: {
random: () => Math.random()
}
}
});
} catch(e) {
if(e instanceof WebAssembly.CompileError) {

294
game.scm
View file

@ -18,235 +18,26 @@
;;;
;;; Code:
(import (scheme base)
(scheme inexact)
(hoot debug)
(hoot ffi)
(hoot hashtables)
(hoot match)
(dom canvas)
(use-modules (dom canvas)
(dom document)
(dom element)
(dom event)
(dom image)
(dom media)
(dom window)
(hoot ffi)
(hoot hashtables)
(ice-9 match)
(math)
(math rect)
(math vector))
;; Data types
(define-record-type <brick-type>
(make-brick-type image points)
brick-type?
(image brick-type-image)
(points brick-type-points))
(define-record-type <brick>
(make-brick type hitbox)
brick?
(type brick-type)
(hitbox brick-hitbox)
(broken? brick-broken? set-brick-broken!))
(define-record-type <ball>
(make-ball velocity hitbox)
ball?
(velocity ball-velocity)
(hitbox ball-hitbox))
(define-record-type <paddle>
(make-paddle velocity hitbox)
paddle?
(velocity paddle-velocity)
(hitbox paddle-hitbox))
(define-record-type <level>
(make-level state bricks ball paddle score move-left? move-right?)
level?
(state level-state set-level-state!) ; play, win, lose
(bricks level-bricks)
(ball level-ball)
(paddle level-paddle)
(score level-score set-level-score!)
(move-left? level-move-left? set-level-move-left!)
(move-right? level-move-right? set-level-move-right!))
;; Assets
(define image:paddle (make-image "assets/images/paddle.png"))
(define image:ball (make-image "assets/images/ball.png"))
(define image:brick-red (make-image "assets/images/brick-red.png"))
(define image:brick-green (make-image "assets/images/brick-green.png"))
(define image:brick-blue (make-image "assets/images/brick-blue.png"))
(define audio:brick (make-audio "assets/sounds/brick.wav"))
(define audio:paddle (make-audio "assets/sounds/paddle.wav"))
;; Game data
(define game-width 640.0)
(define game-height 480.0)
(define brick-width 64.0)
(define brick-height 32.0)
(define ball-width 22.0)
(define ball-height 22.0)
(define paddle-width 104.0)
(define paddle-height 24.0)
(define paddle-speed 6.0)
(define brick:red (make-brick-type image:brick-red 10))
(define brick:green (make-brick-type image:brick-green 20))
(define brick:blue (make-brick-type image:brick-blue 30))
(define (make-brick* type x y)
(make-brick type (make-rect x y brick-width brick-height)))
(define (make-brick-grid types)
(let* ((h (vector-length types))
(w (vector-length (vector-ref types 0)))
(offset-x (/ (- game-width (* w brick-width)) 2.0))
(offset-y 48.0)
(bricks (make-vector (* w h))))
(do ((y 0 (+ y 1)))
((= y h))
(let ((row (vector-ref types y)))
(do ((x 0 (+ x 1)))
((= x w))
(vector-set! bricks (+ (* y w) x)
(make-brick* (vector-ref row x)
(+ offset-x (* x brick-width))
(+ offset-y (* y brick-height)))))))
bricks))
(define (make-level-1)
(make-level 'play
(make-brick-grid
(vector
(vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green)
(vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue)
(vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red)
(vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green)
(vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue)
(vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red)))
(make-ball (vec2 1.0 3.0)
(make-rect (/ game-width 2.0) (/ game-height 2.0)
ball-width ball-height))
(make-paddle (vec2 0.0 0.0)
(make-rect (- (/ game-width 2.0)
(/ paddle-width 2.0))
(- game-height paddle-height 8.0)
paddle-width paddle-height))
0 #f #f))
;; Game state
(define *level* (make-level-1))
(define (level-clear? level)
(let ((bricks (level-bricks level)))
(let loop ((i 0))
(if (< i (vector-length bricks))
(if (brick-broken? (vector-ref bricks i))
(loop (+ i 1))
#f)
#t))))
(define (win! level)
(set-level-state! level 'win))
(define (lose! level)
(set-level-state! level 'lose))
(define (update-paddle-velocity! level)
(let ((speed (* paddle-speed
(+ (if (level-move-left? level) -1.0 0.0)
(if (level-move-right? level) 1.0 0.0)))))
(set-vec2-x! (paddle-velocity (level-paddle level)) speed)))
(define (speed-up-ball! ball)
(let* ((v (ball-velocity ball))
(speed (+ (vec2-magnitude v) (* (random) 0.1)))
;; Also change its angle slightly. Not the proper Breakout
;; behavior but I don't want to write the code for that. :)
(dir (+ (atan (vec2-y v) (vec2-x v))
(- (* (random) 0.5) 0.25))))
(set-vec2-x! v (* (cos dir) speed))
(set-vec2-y! v (* (sin dir) speed))))
(define (reflect-ball! ball x? y?)
(let ((v (ball-velocity ball)))
(when x? (set-vec2-x! v (- (vec2-x v))))
(when y? (set-vec2-y! v (- (vec2-y v))))))
(define (collide-ball! ball hitbox)
(let ((b-hitbox (ball-hitbox ball)))
(and (rect-intersects? b-hitbox hitbox)
(let ((overlap (rect-clip b-hitbox hitbox)))
;; Resolve collision by adjusting the ball's position the
;; minimum amount along the X or Y axis.
(if (< (rect-width overlap) (rect-height overlap))
(begin
(reflect-ball! ball #t #f)
(if (= (rect-x b-hitbox) (rect-x overlap))
(set-rect-x! b-hitbox (+ (rect-x b-hitbox) (rect-width overlap)))
(set-rect-x! b-hitbox (- (rect-x b-hitbox) (rect-width overlap)))))
(begin
(reflect-ball! ball #f #t)
(if (= (rect-y b-hitbox) (rect-y overlap))
(set-rect-y! b-hitbox (+ (rect-y b-hitbox) (rect-height overlap)))
(set-rect-y! b-hitbox (- (rect-y b-hitbox) (rect-height overlap))))))))))
(define game-width 320.0)
(define game-height 240.0)
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
(match (level-state *level*)
('play
(let* ((bricks (level-bricks *level*))
(ball (level-ball *level*))
(b-velocity (ball-velocity ball))
(b-hitbox (ball-hitbox ball))
(paddle (level-paddle *level*))
(p-velocity (paddle-velocity paddle))
(p-hitbox (paddle-hitbox paddle))
(score (level-score *level*)))
;; Move ball and paddle
(set-rect-x! b-hitbox (+ (rect-x b-hitbox) (vec2-x b-velocity)))
(set-rect-y! b-hitbox (+ (rect-y b-hitbox) (vec2-y b-velocity)))
;; We only move the paddle along the x-axis.
(set-rect-x! p-hitbox
(clamp (+ (rect-x p-hitbox) (vec2-x p-velocity))
0.0
(- game-width paddle-width)))
;; Collide ball against walls, bricks, and paddle.
(cond
((< (rect-x b-hitbox) 0.0) ; left wall
(set-rect-x! b-hitbox 0.0)
(reflect-ball! ball #t #f))
((> (+ (rect-x b-hitbox) (rect-width b-hitbox)) game-width) ; right wall
(set-rect-x! b-hitbox (- game-width (rect-width b-hitbox)))
(reflect-ball! ball #t #f))
((< (rect-y b-hitbox) 0.0) ; top wall
(set-rect-y! b-hitbox 0.0)
(reflect-ball! ball #f #t))
((> (+ (rect-y b-hitbox) (rect-height b-hitbox)) game-height) ; bottom wall
(lose! *level*))
((collide-ball! ball (paddle-hitbox paddle))
(media-play audio:paddle)
(speed-up-ball! ball))
(else
(let loop ((i 0) (hit? #f))
(if (< i (vector-length bricks))
(let ((brick (vector-ref bricks i)))
(if (and (not (brick-broken? brick))
(collide-ball! ball (brick-hitbox brick)))
(begin
(media-play audio:brick)
(speed-up-ball! ball)
(set-brick-broken! brick #t)
(set-level-score! *level*
(+ (level-score *level*)
(brick-type-points (brick-type brick))))
(loop (+ i 1) #t))
(loop (+ i 1) hit?)))
;; Maybe change to win state if all bricks are broken.
(when (and hit? (level-clear? *level*))
(win! *level*))))))))
(_ #t))
#t
(timeout update-callback dt))
(define update-callback (procedure->external update))
@ -260,53 +51,12 @@
str)))))
(define (draw prev-time)
(let ((bricks (level-bricks *level*))
(ball (level-ball *level*))
(paddle (level-paddle *level*))
(score (level-score *level*)))
;; Draw background
(set-fill-color! context "#140c1c")
(fill-rect context 0.0 0.0 game-width game-height)
;; Draw bricks
(do ((i 0 (+ i 1)))
((= i (vector-length bricks)))
(let* ((brick (vector-ref bricks i))
(type (brick-type brick))
(hitbox (brick-hitbox brick)))
(unless (brick-broken? brick)
(draw-image context (brick-type-image type)
0.0 0.0
brick-width brick-height
(rect-x hitbox) (rect-y hitbox)
brick-width brick-height))))
;; Draw paddle
(let ((w 104.0)
(h 24.0)
(hitbox (paddle-hitbox paddle)))
(draw-image context image:paddle
0.0 0.0 w h
(rect-x hitbox) (rect-y hitbox) w h))
;; Draw ball
(let ((w 22.0)
(h 22.0)
(hitbox (ball-hitbox ball)))
(draw-image context image:ball
0.0 0.0 w h
(rect-x hitbox) (rect-y hitbox) w h))
;; Print score
(set-fill-color! context "#ffffff")
(set-font! context "bold 24px monospace")
(set-text-align! context "left")
(fill-text context "SCORE:" 16.0 36.0)
(fill-text context (number->string* score) 108.0 36.0)
(match (level-state *level*)
('win
(set-text-align! context "center")
(fill-text context "YAY YOU DID IT!!!" (/ game-width 2.0) (/ game-height 2.0)))
('lose
(set-text-align! context "center")
(fill-text context "OH NO, GAME OVER :(" (/ game-width 2.0) (/ game-height 2.0)))
(_ #t)))
(fill-text context "HELLO" 16.0 36.0)
(request-animation-frame draw-callback))
(define draw-callback (procedure->external draw))
@ -317,37 +67,17 @@
(define (on-key-down event)
(let ((key (keyboard-event-code event)))
(match (level-state *level*)
('play
(cond
((string=? key key:left)
(set-level-move-left! *level* #t)
(update-paddle-velocity! *level*))
((string=? key key:right)
(set-level-move-right! *level* #t)
(update-paddle-velocity! *level*))))
((or 'win 'lose)
(when (string=? key key:confirm)
(set! *level* (make-level-1)))))))
(pk 'key-down key)))
(define (on-key-up event)
(let ((key (keyboard-event-code event)))
(match (level-state *level*)
('play
(cond
((string=? key key:left)
(set-level-move-left! *level* #f)
(update-paddle-velocity! *level*))
((string=? key key:right)
(set-level-move-right! *level* #f)
(update-paddle-velocity! *level*))))
(_ #t))))
(pk 'key-up key)))
;; Canvas and event loop setup
(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))
(set-element-width! canvas (exact game-width))
(set-element-height! canvas (exact game-height))
(set-element-width! canvas (inexact->exact game-width))
(set-element-height! canvas (inexact->exact game-height))
(add-event-listener! (current-document) "keydown"
(procedure->external on-key-down))
(add-event-listener! (current-document) "keyup"

43
modules/goblins/abstract-types.scm Normal file
View file

@ -0,0 +1,43 @@
;;; Copyright 2023 Jessica Tallon
;;;
;;; 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 (goblins abstract-types)
#:export (zilch
zilch?
<tagged>
make-tagged
make-tagged*
tagged?
tagged-label
tagged-data))
;; This is both a 2nd and secondary "bottom" or null/void type that's used
;; within CapTP. This works alongside guile's *unspecified* bottom type.
(define (make-zilch)
(define-record-type <zilch>
(_make-zilch)
zilch?)
(values (_make-zilch) zilch?))
(define-values (zilch zilch?)
(make-zilch))
(define-record-type <tagged>
(make-tagged label data)
tagged?
(label tagged-label)
(data tagged-data))
(define (make-tagged* label . args)
(make-tagged label args))

237
modules/goblins/core-types.scm Normal file
View file

@ -0,0 +1,237 @@
;;; Copyright 2019-2023 Christine Lemmer-Webber
;;; Copyright 2023 David Thompson
;;; Copyright 2022-2024 Jessica Tallon
;;; Copyright 2023 Juliana Sims
;;;
;;; 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.
;; This module should largely be considered private and should typically
;; not be used directly. If you need these things, most of them are
;; exported from core and if they haven't been, likely it's because you
;; don't need them.
(define-module (goblins core-types)
#:use-module (hoot hashtables)
#:use-module (ice-9 match)
#:export (<actormap>
_make-actormap
actormap?
actormap-metatype
actormap-data
actormap-vat-connector
actormap-ref
actormap-set!
<actormap-metatype>
make-actormap-metatype
actormap-metatype?
actormap-metatype-name
actormap-metatype-ref-proc
actormap-metatype-set!-proc
<whactormap-data>
make-whactormap-data
whactormap-data?
whactormap-data-wht
whactormap?
whactormap-ref
whactormap-set!
whactormap-metatype
<transactormap-data>
make-transactormap-data
transactormap-data?
transactormap-data-parent
transactormap-data-delta
transactormap-data-merged?
set-transactormap-data-merged?!
transactormap-merged?
<local-object-refr>
make-local-object-refr
local-object-refr?
local-object-refr-debug-name
local-object-refr-vat-connector
<local-promise-refr>
make-local-promise-refr
local-promise-refr?
local-promise-refr-vat-connector
<remote-object-refr>
make-remote-object-refr
remote-object-refr?
remote-object-refr-captp-connector
remote-object-refr-sealed-pos
<remote-promise-refr>
make-remote-promise-refr
remote-promise-refr?
remote-promise-refr-captp-connector
remote-promise-refr-sealed-pos
local-refr?
local-refr-vat-connector
remote-refr?
remote-refr-captp-connector
remote-refr-sealed-pos
live-refr?
promise-refr?))
;; hoot hacks
(define *unspecified* (if #f #f))
;; Actormaps, etc
;; ==============
(define-record-type <actormap>
;; TODO: This is confusing, naming-wise? (see make-actormap alias)
(_make-actormap metatype data vat-connector)
actormap?
(metatype actormap-metatype)
(data actormap-data)
(vat-connector actormap-vat-connector))
(define-record-type <actormap-metatype>
(make-actormap-metatype name ref-proc set!-proc)
actormap-metatype?
(name actormap-metatype-name)
(ref-proc actormap-metatype-ref-proc)
(set!-proc actormap-metatype-set!-proc))
(define (actormap-set! am key val)
((actormap-metatype-set!-proc (actormap-metatype am))
am key val)
*unspecified*)
;; (-> actormap? local-refr? (or/c mactor? #f))
(define (actormap-ref am key)
((actormap-metatype-ref-proc (actormap-metatype am)) am key))
(define-record-type <whactormap-data>
(make-whactormap-data wht)
whactormap-data?
(wht whactormap-data-wht))
(define (whactormap? obj)
"Return #t if OBJ is a weak-hash actormap, else #f.
Type: Any -> Boolean"
(and (actormap? obj)
(eq? (actormap-metatype obj) whactormap-metatype)))
(define (whactormap-ref am key)
(define wht (whactormap-data-wht (actormap-data am)))
(weak-key-hashtable-ref wht key #f))
(define (whactormap-set! am key val)
(define wht (whactormap-data-wht (actormap-data am)))
(weak-key-hashtable-set! wht key val))
(define whactormap-metatype
(make-actormap-metatype 'whactormap whactormap-ref whactormap-set!))
;; Transactional actormaps
;; =======================
(define-record-type <transactormap-data>
(make-transactormap-data parent delta merged?)
transactormap-data?
(parent transactormap-data-parent)
(delta transactormap-data-delta)
(merged? transactormap-data-merged? set-transactormap-data-merged?!))
(define (transactormap-merged? transactormap)
(transactormap-data-merged? (actormap-data transactormap)))
;; Ref(r)s
;; =======
(define-record-type <local-object-refr>
(make-local-object-refr debug-name vat-connector)
local-object-refr?
(debug-name local-object-refr-debug-name)
(vat-connector local-object-refr-vat-connector))
(define-record-type <local-promise-refr>
(make-local-promise-refr vat-connector)
local-promise-refr?
(vat-connector local-promise-refr-vat-connector))
(define (local-refr? obj)
"Return #t if OBJ is an object or promise reference in the current
process, else #f.
Type: Any -> Boolean"
(or (local-object-refr? obj) (local-promise-refr? obj)))
(define (local-refr-vat-connector local-refr)
(match local-refr
[(? local-object-refr?)
(local-object-refr-vat-connector local-refr)]
[(? local-promise-refr?)
(local-promise-refr-vat-connector local-refr)]))
;; Captp-connector should be a procedure which both sends a message
;; to the local node representative actor, but also has something
;; serialized that knows which specific remote node + session this
;; corresponds to (to look up the right captp session and forward)
(define-record-type <remote-object-refr>
(make-remote-object-refr captp-connector sealed-pos)
remote-object-refr?
(captp-connector remote-object-refr-captp-connector)
(sealed-pos remote-object-refr-sealed-pos))
(define-record-type <remote-promise-refr>
(make-remote-promise-refr captp-connector sealed-pos)
remote-promise-refr?
(captp-connector remote-promise-refr-captp-connector)
(sealed-pos remote-promise-refr-sealed-pos))
(define (promise-refr? maybe-promise)
"Return #t if MAYBE-PROMISE is a promise reference, else #f.
Type: Any -> Boolean"
(or (local-promise-refr? maybe-promise) (remote-promise-refr? maybe-promise)))
(define (remote-refr-captp-connector remote-refr)
(match remote-refr
[(? remote-object-refr?)
(remote-object-refr-captp-connector remote-refr)]
[(? remote-promise-refr?)
(remote-promise-refr-captp-connector remote-refr)]))
(define (remote-refr-sealed-pos remote-refr)
(match remote-refr
[(? remote-object-refr?)
(remote-object-refr-sealed-pos remote-refr)]
[(? remote-promise-refr?)
(remote-promise-refr-sealed-pos remote-refr)]))
(define (remote-refr? obj)
"Return #t if OBJ is an object or promise reference in a different
process, else #f.
Type: Any -> Boolean"
(or (remote-object-refr? obj)
(remote-promise-refr? obj)))
(define (live-refr? obj)
"Return #t if OBJ is a local or remote object or promise reference,
else #f.
Type: Any -> Boolean"
(or (local-refr? obj)
(remote-refr? obj)))

2370
modules/goblins/core.scm Normal file
View file

File diff suppressed because it is too large Load diff

239
modules/goblins/ghash.scm Normal file
View file

@ -0,0 +1,239 @@
;;; Copyright 2021-2024 Christine Lemmer-Webber
;;; Copyright 2024 Jessica Tallon
;;;
;;; 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.
;; An immutable hashtable with specific set/ref conventions. Refrs
;; are hashed by eq?, everything else is hashed by equal?.
;;
;; TODO: Really presently built on top of vhashes. Might be built on
;; top of something else, like fashes, in the future. Especially since
;; vhashes are not thread safe...
(define-module (goblins ghash)
;; NOTE: Do not depend on core because it depends on us.
#:use-module (goblins core-types)
#:use-module (ice-9 vlist)
#:use-module (hoot hashtables)
#:use-module ((hoot lists) #:select (fold))
#:use-module (ice-9 match)
#:use-module (scheme write)
#:export (make-ghash
ghash?
ghash-set
ghash-ref
ghash-remove
ghash-null
ghash-length
ghash-has-key?
ghash-fold
ghash-fold-right
ghash-for-each
hashtable->ghash
make-gset
gset?
gset-add
gset-remove
gset-length
gset->list
gset-member?
gset-fold
gset-for-each))
;; hoot hacks
(define (hashtable-fold proc init table)
(let ((acc init))
(hashtable-for-each
(lambda (k v)
(set! acc (proc k v acc)))
table)))
(define-record-type <ghash>
(_make-ghash vhash)
ghash?
(vhash ghash-vhash))
(define (vhash-length vhash)
(vhash-fold (lambda (_k _v count) (+ count 1))
0 vhash))
(define (print-ghash vhash port)
(display
(string-append
"#<ghash (" (vhash-length (ghash-vhash vhash)) ")>")
port))
(define ghash-null (_make-ghash vlist-null))
(define (make-ghash . key-vals)
(_make-ghash
(let lp ((key-vals key-vals)
(vh vlist-null))
(match key-vals
[() vh]
[(key val . rest)
(lp rest
(_vh-set vh key val))]))))
(define (_vh-set vh key val)
(define conser
(if (or (live-refr? key) (symbol? key))
vhash-consq
vhash-cons))
(conser key val vh))
(define (ghash-set ghash key val)
(define vh (ghash-vhash ghash))
(_make-ghash (_vh-set vh key val)))
(define* (ghash-ref ghash key #:optional [dflt #f])
(define vh (ghash-vhash ghash))
(define assoc
(if (or (live-refr? key) (symbol? key))
vhash-assq
vhash-assoc))
(match (assoc key vh)
((_k . val) val)
(#f dflt)))
(define (ghash-has-key? ghash key)
(define vh (ghash-vhash ghash))
(define assoc
(if (or (live-refr? key) (symbol? key))
vhash-assq
vhash-assoc))
(match (assoc key vh)
((_k . val) #t)
(#f #f)))
(define (ghash-remove ghash key)
(define vh (ghash-vhash ghash))
(define del
(if (or (live-refr? key) (symbol? key))
vhash-delq
vhash-delete))
(_make-ghash (del key vh)))
(define (ghash-length ghash)
(vlist-length (ghash-vhash ghash)))
(define (ghash-fold proc init ghash)
(vhash-fold proc init (ghash-vhash ghash)))
(define (ghash-fold-right proc init ghash)
(vhash-fold-right proc init (ghash-vhash ghash)))
(define (ghash-for-each proc ghash)
(vhash-fold
(lambda (k v _p)
(proc k v))
#f
(ghash-vhash ghash)))
(define (hashtable->ghash table)
(_make-ghash
(hashtable-fold
(lambda (key val vh)
(_vh-set vh key val))
vlist-null
table)))
;;; Sets
(define-record-type <gset>
(_make-gset ht)
gset?
(ht _set-ht))
(define (print-set set port)
(define items
(vhash-fold
(lambda (k _v prev)
(cons k prev))
'()
(_set-ht set)))
(display (string-append "#<gset " items ">") port))
(define (make-gset . items)
(define vh
(fold
(lambda (item vh)
(define-values (add assoc)
(if (or (live-refr? item) (symbol? item))
(values vhash-consq vhash-assoc)
(values vhash-cons vhash-assq)))
;; Ensure it's unique to the set
(if (assoc item vh)
vh
(add item #t vh)))
vlist-null items))
(_make-gset vh))
(define (gset-add set item)
(define add
(if (or (live-refr? item) (symbol? item))
vhash-consq
vhash-cons))
(if (gset-member? set item)
set
(_make-gset (add item #t (_set-ht set)))))
(define (gset-remove set item)
(define del
(if (or (live-refr? item) (symbol? item))
vhash-delq
vhash-delete))
(_make-gset (del item (_set-ht set))))
(define (gset-fold proc init set)
(vhash-fold
(lambda (key _val prev)
(proc key prev))
init
(_set-ht set)))
(define (gset-length set)
(vhash-fold
(lambda (_k _v count)
(+ count 1))
0
(_set-ht set)))
(define (gset->list set)
(vhash-fold
(lambda (key _val prev)
(cons key prev))
'()
(_set-ht set)))
(define (gset-member? set key)
(define assoc
(if (or (live-refr? key) symbol? key)
vhash-assq
vhash-assoc))
(match (assoc key (_set-ht set))
[(_val . #t) #t]
[#f #f]))
(define (gset-for-each proc set)
(vhash-fold
(lambda (k v _p)
(proc k v))
#f
(_set-ht set)))

65
modules/guile/list.scm Normal file
View file

@ -0,0 +1,65 @@
;;; List compatibility procedures/macros for Guile
;;; Copyright © 2024 Juliana Sims <juli@incana.org>
;;;
;;; 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.
;;; Commentary:
;;;
;;; These match APIs exposed in Guile's environment but not yet available in
;;; Hoot.
;;; Code:
(define-module (guile list)
#:export (delete delq delq! last-pair))
(define (fold proc acc lst)
(if (null? lst)
acc
(fold proc
(proc (car lst) acc)
(cdr lst))))
(define (fold-right proc acc lst)
(fold proc acc (reverse lst)))
(define (last-pair lst)
(if (null? (cdr lst))
lst
(last-pair (cdr lst))))
(define (delete item lst . eq-pair)
(define eq (if (pair? eq-pair) (car eq-pair) equal?))
(fold-right (lambda (i acc)
(if (eq i item)
acc
(cons i acc)))
'() lst))
(define (delq item lst)
(delete item lst eq?))
;; This matches the semantics of Guile's delq!, but using set-car! means we
;; could actually improve delq! by ensuring eq? between an original list
;; starting with ITEM and a delq! removing ITEM from that list. Guile's delq!
;; does not provide this functionality because it does not destructively
;; remove the list's car
(define (delq! item lst)
(let ((delqd-lst (delq item lst)))
(if (eq? (car lst) item)
(and (set-cdr! lst delqd-lst)
delqd-lst)
(and (set-cdr! lst (cdr delqd-lst))
(set-car! lst (car delqd-lst))
lst))))

48
modules/ice-9/control.scm Normal file
View file

@ -0,0 +1,48 @@
;;; Copyright (C) 2010, 2011, 2013, 2024 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This is a convenience module for porting Goblins to Hoot while Guile support
;;; is incomplete. It simply re-exports some extant Hoot prompt functionality
;;; and adds call-with-escape-continuation and call/ec.
;;;
;;; Code:
(define-module (ice-9 control)
#:use-module (hoot control)
#:export (make-prompt-tag
default-prompt-tag
call-with-prompt
abort-to-prompt
%
default-prompt-handler
call-with-escape-continuation
call/ec))
(define (call-with-escape-continuation proc)
"Call PROC with an escape continuation."
(let ((tag (list 'call/ec)))
(call-with-prompt tag
(lambda ()
(proc (lambda args
(apply abort-to-prompt tag args))))
(lambda (_ . args)
(apply values args)))))
(define call/ec call-with-escape-continuation)

171
modules/ice-9/q.scm Normal file
View file

@ -0,0 +1,171 @@
;;; Guile's (ice-9 q) module modified for Hoot
;;;; Copyright (C) 1995, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Guile's q module for use with Hoot
;;;
;;; This is exactly the code from Guile, including comments, using error instead
;;; of throw for erroring. It also pulls in other Guile compatibility modules
;;; and uses R6RS-style library declarations.
;;;
;;; Original commentary:
;;;
;;; Q: Based on the interface to
;;;
;;; "queue.scm" Queues/Stacks for Scheme
;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
;;; {Q}
;;;
;;; A list is just a bunch of cons pairs that follows some constrains,
;;; right? Association lists are the same. Hash tables are just
;;; vectors and association lists. You can print them, read them,
;;; write them as constants, pun them off as other data structures
;;; etc. This is good. This is lisp. These structures are fast and
;;; compact and easy to manipulate arbitrarily because of their
;;; simple, regular structure and non-disjointedness (associations
;;; being lists and so forth).
;;;
;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
;;; structures in general.
;;;
;;; A queue is a cons pair:
;;; ( <the-q> . <last-pair> )
;;;
;;; <the-q> is a list of things in the q. New elements go at the end
;;; of that list.
;;;
;;; <last-pair> is #f if the q is empty, and otherwise is the last
;;; pair of <the-q>.
;;;
;;; q's print nicely, but alas, they do not read well because the
;;; eq?-ness of <last-pair> and (last-pair <the-q>) is lost by read.
;;;
;;; All the functions that aren't explicitly defined to return
;;; something else (a queue element; a boolean value) return the queue
;;; object itself.
;;; Code:
(define-module (ice-9 q)
#:use-module (guile list)
#:export (deq!
enq!
make-q
q?
q-empty?
q-empty-check
q-front
q-length
q-pop!
q-push!
q-rear
q-remove!
sync-q!))
;;; sync-q!
;;; The procedure
;;;
;;; (sync-q! q)
;;;
;;; recomputes and resets the <last-pair> component of a queue.
;;;
(define (sync-q! q)
(set-cdr! q (if (pair? (car q)) (last-pair (car q))
#f))
q)
;;; make-q
;;; return a new q.
;;;
(define (make-q) (cons '() #f))
;;; q? obj
;;; Return true if obj is a Q.
;;; An object is a queue if it is equal? to '(() . #f)
;;; or it is a pair P with (list? (car P))
;;; and (eq? (cdr P) (last-pair (car P))).
;;;
(define (q? obj)
(and (pair? obj)
(if (pair? (car obj))
(eq? (cdr obj) (last-pair (car obj)))
(and (null? (car obj))
(not (cdr obj))))))
;;; q-empty? obj
;;;
(define (q-empty? obj) (null? (car obj)))
;;; q-empty-check q
;;; Throw a q-empty exception if Q is empty.
(define (q-empty-check q) (if (q-empty? q) (error "empty queue" q)))
;;; q-front q
;;; Return the first element of Q.
(define (q-front q) (q-empty-check q) (caar q))
;;; q-rear q
;;; Return the last element of Q.
(define (q-rear q) (q-empty-check q) (cadr q))
;;; q-remove! q obj
;;; Remove all occurences of obj from Q.
(define (q-remove! q obj)
(set-car! q (delq! obj (car q)))
(sync-q! q))
;;; q-push! q obj
;;; Add obj to the front of Q
(define (q-push! q obj)
(let ((h (cons obj (car q))))
(set-car! q h)
(or (cdr q) (set-cdr! q h)))
q)
;;; enq! q obj
;;; Add obj to the rear of Q
(define (enq! q obj)
(let ((h (cons obj '())))
(if (null? (car q))
(set-car! q h)
(set-cdr! (cdr q) h))
(set-cdr! q h))
q)
;;; q-pop! q
;;; Take the front of Q and return it.
(define (q-pop! q)
(q-empty-check q)
(let ((it (caar q))
(next (cdar q)))
(if (null? next)
(set-cdr! q #f))
(set-car! q next)
it))
;;; deq! q
;;; Take the front of Q and return it.
(define deq! q-pop!)
;;; q-length q
;;; Return the number of enqueued elements.
;;;
(define (q-length q) (length (car q)))
;;; q.scm ends here

595
modules/ice-9/vlist.scm Normal file
View file

@ -0,0 +1,595 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010, 2011, 2012, 2024 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Ludovic Courtès <ludo@gnu.org>
;;;
;;; Commentary:
;;;
;;; This is a port of Guile's (ice-9 vlist) for Hoot. It is derived from the
;;; upstream module and differs only as necessary to work with Hoot. The
;;; original developer's commentary continues below.
;;;
;;; This module provides an implementations of vlists, a functional list-like
;;; data structure described by Phil Bagwell in "Fast Functional Lists,
;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
;;; 2002.
;;;
;;; The idea is to store vlist elements in increasingly large contiguous blocks
;;; (implemented as vectors here). These blocks are linked to one another using
;;; a pointer to the next block (called `block-base' here) and an offset within
;;; that block (`block-offset' here). The size of these blocks form a geometric
;;; series with ratio `block-growth-factor'.
;;;
;;; In the best case (e.g., using a vlist returned by `list->vlist'),
;;; elements from the first half of an N-element vlist are accessed in O(1)
;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
;;; O(ln(N)). Furthermore, the data structure improves data locality since
;;; vlist elements are adjacent, which plays well with caches.
;;;
;;; Code:
(define-module (ice-9 vlist)
#:use-module (hoot fluids)
#:use-module (hoot hashtables)
#:use-module ((hoot lists) #:select (fold))
#:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-drop vlist-take
vlist-length vlist-fold vlist-fold-right vlist-map
vlist-unfold vlist-unfold-right vlist-append
vlist-reverse vlist-filter vlist-delete vlist->list
vlist-for-each
block-growth-factor
vhash? vhash-cons vhash-consq vhash-consv
vhash-assoc vhash-assq vhash-assv
vhash-delete vhash-delq vhash-delv
vhash-fold vhash-fold-right
vhash-fold* vhash-foldq* vhash-foldv*
alist->vhash))
;;; Hoot Hacks™ (not really ™)
;; XXX hashes using equal? and eqv? have not been defined; use only eq?
(define equal? eq?)
(define eqv? eq?)
(define hash hashq)
(define hashv hashq)
(define (fold-right proc init lst)
(fold proc init (reverse lst)))
;;;
;;; VList Blocks and Block Descriptors.
;;;
(define block-growth-factor
(make-fluid 2))
(define (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to
;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
;; "hash table". Note: We use `next-free' instead of `last-used' as
;; suggested by Bagwell.
(if hash-tab?
(vector (make-vector (* size 3) #f)
base offset size 0)
(vector (make-vector size)
base offset size 0)))
(define-syntax define-block-accessor
(syntax-rules ()
((_ name index)
(define (name block)
(vector-ref block index)))))
(define-block-accessor block-content 0)
(define-block-accessor block-base 1)
(define-block-accessor block-offset 2)
(define-block-accessor block-size 3)
(define-block-accessor block-next-free 4)
(define (block-hash-table? block)
(< (block-size block) (vector-length (block-content block))))
(define (set-block-next-free! block next-free)
(vector-set! block 4 next-free))
(define (block-append! block value offset)
;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
(and (< offset (block-size block))
(= offset (block-next-free block))
(begin
(set-block-next-free! block (+ offset 1))
(vector-set! (block-content block) offset value)
#t)))
;; Return the item at slot OFFSET.
(define (block-ref content offset)
(vector-ref content offset))
;; Return the offset of the next item in the hash bucket, after the one
;; at OFFSET.
(define (block-hash-table-next-offset content size offset)
(vector-ref content (+ size size offset)))
;; Save the offset of the next item in the hash bucket, after the one
;; at OFFSET.
(define (block-hash-table-set-next-offset! content size offset
next-offset)
(vector-set! content (+ size size offset) next-offset))
;; Returns the index of the last entry stored in CONTENT with
;; SIZE-modulo hash value KHASH.
(define (block-hash-table-ref content size khash)
(vector-ref content (+ size khash)))
(define (block-hash-table-set! content size khash offset)
(vector-set! content (+ size khash) offset))
;; Add hash table information for the item recently added at OFFSET,
;; with SIZE-modulo hash KHASH.
(define (block-hash-table-add! content size khash offset)
(block-hash-table-set-next-offset! content size offset
(block-hash-table-ref content size khash))
(block-hash-table-set! content size khash offset))
(define block-null
;; The null block.
(make-block #f 0 0 #f))
;;;
;;; VLists.
;;;
(define-record-type <vlist>
;; A vlist is just a base+offset pair pointing to a block.
;; XXX: Allocating a <vlist> record in addition to the block at each
;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it
;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
;; performance hit for everyone.
(make-vlist base offset)
vlist?
(base vlist-base)
(offset vlist-offset))
(define vlist-null
;; The empty vlist.
(make-vlist block-null 0))
;; Asserting that something is a vlist is actually a win if your next
;; step is to call record accessors, because that causes CSE to
;; eliminate the type checks in those accessors.
;;
(define (assert-vlist val)
(unless (vlist? val)
(error "Not a vlist: " (list val))))
(define (block-cons item vlist hash-tab?)
(let ((base (vlist-base vlist))
(offset (+ (vlist-offset vlist) 1)))
(cond
((block-append! base item offset)
;; Fast path: We added the item directly to the block.
(make-vlist base offset))
(else
;; Slow path: Allocate a new block.
(let* ((size (block-size base))
(base (make-block
base
(- offset 1)
(cond
((zero? size) 1)
((< offset size) 1) ;; new vlist head
(else (* (fluid-ref block-growth-factor) size)))
hash-tab?)))
(set-block-next-free! base 1)
(vector-set! (block-content base) 0 item)
(make-vlist base 0))))))
(define (vlist-cons item vlist)
"Return a new vlist with ITEM as its head and VLIST as its
tail."
;; Note: Although the result of `vlist-cons' on a vhash is a valid
;; vlist, it is not a valid vhash. The new item does not get a hash
;; table entry. If we allocate a new block, the new block will not
;; have a hash table. Perhaps we can do something more sensible here,
;; but this is a hot function, so there are performance impacts.
(assert-vlist vlist)
(block-cons item vlist #f))
(define (vlist-head vlist)
"Return the head of VLIST."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(block-ref (block-content base) offset)))
(define (vlist-tail vlist)
"Return the tail of VLIST."
(assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (> offset 0)
(make-vlist base (- offset 1))
(make-vlist (block-base base)
(block-offset base)))))
(define (vlist-null? vlist)
"Return true if VLIST is empty."
(assert-vlist vlist)
(let ((base (vlist-base vlist)))
(and (not (block-base base))
(= 0 (block-size base)))))
;;;
;;; VList Utilities.
;;;
(define (list->vlist lst)
"Return a new vlist whose contents correspond to LST."
(vlist-reverse (fold vlist-cons vlist-null lst)))
(define (vlist-fold proc init vlist)
"Fold over VLIST, calling PROC for each element."
;; FIXME: Handle multiple lists.
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist))
(result init))
(if (eq? base block-null)
result
(let* ((next (- offset 1))
(done? (< next 0)))
(loop (if done? (block-base base) base)
(if done? (block-offset base) next)
(proc (block-ref (block-content base) offset) result))))))
(define (vlist-fold-right proc init vlist)
"Fold over VLIST, calling PROC for each element, starting from
the last element."
(assert-vlist vlist)
(let loop ((index (- (vlist-length vlist) 1))
(result init))
(if (< index 0)
result
(loop (- index 1)
(proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist)
"Return a new VLIST whose content are those of VLIST in reverse
order."
(vlist-fold vlist-cons vlist-null vlist))
(define (vlist-map proc vlist)
"Map PROC over the elements of VLIST and return a new vlist."
(vlist-fold (lambda (item result)
(vlist-cons (proc item) result))
vlist-null
(vlist-reverse vlist)))
(define (vlist->list vlist)
"Return a new list whose contents match those of VLIST."
(vlist-fold-right cons '() vlist))
(define (vlist-ref vlist index)
"Return the element at index INDEX in VLIST."
(assert-vlist vlist)
(let loop ((index index)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= index offset)
(block-ref (block-content base) (- offset index))
(loop (- index offset 1)
(block-base base)
(block-offset base)))))
(define (vlist-drop vlist count)
"Return a new vlist that does not contain the COUNT first elements of
VLIST."
(assert-vlist vlist)
(let loop ((count count)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= count offset)
(make-vlist base (- offset count))
(loop (- count offset 1)
(block-base base)
(block-offset base)))))
(define (vlist-take vlist count)
"Return a new vlist that contains only the COUNT first elements of
VLIST."
(let loop ((count count)
(vlist vlist)
(result vlist-null))
(if (= 0 count)
(vlist-reverse result)
(loop (- count 1)
(vlist-tail vlist)
(vlist-cons (vlist-head vlist) result)))))
(define (vlist-filter pred vlist)
"Return a new vlist containing all the elements from VLIST that
satisfy PRED."
(vlist-fold-right (lambda (e v)
(if (pred e)
(vlist-cons e v)
v))
vlist-null
vlist))
(define* (vlist-delete x vlist #:optional (equal? equal?))
"Return a new vlist corresponding to VLIST without the elements
EQUAL? to X."
(vlist-filter (lambda (e)
(not (equal? e x)))
vlist))
(define (vlist-length vlist)
"Return the length of VLIST."
(assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
(if (eq? base block-null)
len
(loop (block-base base)
(+ len 1 (block-offset base))))))
(define* (vlist-unfold p f g seed
#:optional (tail-gen (lambda (x) vlist-null)))
"Return a new vlist. See the description of SRFI-1 `unfold' for details."
(let uf ((seed seed))
(if (p seed)
(tail-gen seed)
(vlist-cons (f seed)
(uf (g seed))))))
(define* (vlist-unfold-right p f g seed #:optional (tail vlist-null))
"Return a new vlist. See the description of SRFI-1 `unfold-right' for
details."
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
(uf (g seed) (vlist-cons (f seed) lis)))))
(define (vlist-append . vlists)
"Append the given lists."
(if (null? vlists)
vlist-null
(fold-right (lambda (vlist result)
(vlist-fold-right (lambda (e v)
(vlist-cons e v))
result
vlist))
vlist-null
vlists)))
(define (vlist-for-each proc vlist)
"Call PROC on each element of VLIST. The result is unspecified."
(vlist-fold (lambda (item x)
(proc item))
(if #f #f)
vlist))
;;;
;;; Hash Lists, aka. `VHash'.
;;;
;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
;; associated with K1 and K2, respectively. The resulting layout is a
;; follows:
;;
;; ,--------------------.
;; 0| ,-> (K1 . V1) | Vlist array
;; 1| | |
;; 2| | (K2 . V2) |
;; 3| | |
;; size +-|------------------+
;; 0| | | Hash table
;; 1| | |
;; 2| +-- O <------------- H
;; 3| | |
;; size * 2 +-|------------------+
;; 0| `-> 2 | Chain links
;; 1| |
;; 2| #f |
;; 3| |
;; size * 3 `--------------------'
;;
;; The backing store for the vhash is partitioned into three areas: the
;; vlist part, the hash table part, and the chain links part. In this
;; example we have a hash H which, when indexed into the hash table
;; part, indicates that a value with this hash can be found at offset 0
;; in the vlist part. The corresponding index (in this case, 0) of the
;; chain links array holds the index of the next element in this block
;; with this hash value, or #f if we reached the end of the chain.
;;
;; This API potentially requires users to repeat which hash function and
;; which equality predicate to use. This can lead to unpredictable
;; results if they are used in consistenly, e.g., between `vhash-cons'
;; and `vhash-assoc', which is undesirable, as argued in
;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be
;; made in favor of this API:
;;
;; - It's consistent with how alists are handled in SRFI-1.
;;
;; - In practice, users will probably consistenly use either the `q',
;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
;; without any optional argument), i.e., they will rarely explicitly
;; pass a hash function or equality predicate.
(define (vhash? obj)
"Return true if OBJ is a hash list."
(and (vlist? obj)
(block-hash-table? (vlist-base obj))))
(define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on VHASH where KEY is associated
with VALUE. Use HASH to compute KEY's hash."
(assert-vlist vhash)
;; We should also assert that it is a hash table. Need to check the
;; performance impacts of that. Also, vlist-null is a valid hash
;; table, which does not pass vhash?. A bug, perhaps.
(let* ((vhash (block-cons (cons key value) vhash #t))
(base (vlist-base vhash))
(offset (vlist-offset vhash))
(size (block-size base))
(khash (hash key size))
(content (block-content base)))
(block-hash-table-add! content size khash offset)
vhash))
(define (vhash-consq key value vhash)
(vhash-cons key value vhash hashq))
(define (vhash-consv key value vhash)
(vhash-cons key value vhash hashv))
(define (%vhash-fold* proc init key vhash equal? hash)
;; Fold over all the values associated with KEY in VHASH.
(define (visit-block base max-offset result)
(let* ((size (block-size base))
(content (block-content base))
(khash (hash key size)))
(let loop ((offset (block-hash-table-ref content size khash))
(result result))
(if offset
(loop (block-hash-table-next-offset content size offset)
(if (and (<= offset max-offset)
(equal? key (car (block-ref content offset))))
(proc (cdr (block-ref content offset)) result)
result))
(let ((next-block (block-base base)))
(if (> (block-size next-block) 0)
(visit-block next-block (block-offset base) result)
result))))))
(assert-vlist vhash)
(if (> (block-size (vlist-base vhash)) 0)
(visit-block (vlist-base vhash)
(vlist-offset vhash)
init)
init))
(define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash))
"Fold over all the values associated with KEY in VHASH, with each
call to PROC having the form ‘(proc value result)’, where
RESULT is the result of the previous call to PROC and INIT the
value of RESULT for the first call to PROC."
(%vhash-fold* proc init key vhash equal? hash))
(define (vhash-foldq* proc init key vhash)
"Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’."
(%vhash-fold* proc init key vhash eq? hashq))
(define (vhash-foldv* proc init key vhash)
"Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’."
(%vhash-fold* proc init key vhash eqv? hashv))
(define (%vhash-assoc key vhash equal? hash)
;; A specialization of `vhash-fold*' that stops when the first value
;; associated with KEY is found or when the end-of-list is reached. Inline to
;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
;; the `eq?' subr.
(define (visit-block base max-offset)
(let* ((size (block-size base))
(content (block-content base))
(khash (hash key size)))
(let loop ((offset (block-hash-table-ref content size khash)))
(if offset
(if (and (<= offset max-offset)
(equal? key (car (block-ref content offset))))
(block-ref content offset)
(loop (block-hash-table-next-offset content size offset)))
(let ((next-block (block-base base)))
(and (> (block-size next-block) 0)
(visit-block next-block (block-offset base))))))))
(assert-vlist vhash)
(and (> (block-size (vlist-base vhash)) 0)
(visit-block (vlist-base vhash)
(vlist-offset vhash))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from VHASH whose key is equal to
KEY according to the EQUAL? equality predicate."
(%vhash-assoc key vhash equal? hash))
(define (vhash-assq key vhash)
"Return the first key/value pair from VHASH whose key is ‘eq?’ to
KEY."
(%vhash-assoc key vhash eq? hashq))
(define (vhash-assv key vhash)
"Return the first key/value pair from VHASH whose key is ‘eqv?’ to
KEY."
(%vhash-assoc key vhash eqv? hashv))
(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
"Remove all associations from VHASH with KEY, comparing keys
with EQUAL?."
(if (vhash-assoc key vhash equal? hash)
(vlist-fold (lambda (k+v result)
(let ((k (car k+v))
(v (cdr k+v)))
(if (equal? k key)
result
(vhash-cons k v result hash))))
vlist-null
vhash)
vhash))
(define (vhash-delq key vhash)
(vhash-delete key vhash eq? hashq))
(define (vhash-delv key vhash)
(vhash-delete key vhash eqv? hashv))
(define (vhash-fold proc init vhash)
"Fold over the key/pair elements of VHASH from left to right, with
each call to PROC having the form ‘(PROC key value result)’,
where RESULT is the result of the previous call to PROC and
INIT the value of RESULT for the first call to PROC."
(vlist-fold (lambda (key+value result)
(proc (car key+value) (cdr key+value)
result))
init
vhash))
(define (vhash-fold-right proc init vhash)
"Fold over the key/pair elements of VHASH from right to left, with
each call to PROC having the form ‘(PROC key value result)’,
where RESULT is the result of the previous call to PROC and
INIT the value of RESULT for the first call to PROC."
(vlist-fold-right (lambda (key+value result)
(proc (car key+value) (cdr key+value)
result))
init
vhash))
(define* (alist->vhash alist #:optional (hash hash))
"Return the vhash corresponding to ALIST, an association list."
(fold-right (lambda (pair result)
(vhash-cons (car pair) (cdr pair) result hash))
vlist-null
alist))
;;; vlist.scm ends here

15
modules/math.scm
View file

@ -18,21 +18,6 @@
;;;
;;; Code:
;; (library (math)
;; (export random
;; clamp)
;; (import (scheme base)
;; (hoot ffi))
;; (define-foreign random
;; "math" "random"
;; -> f64)
;; (define (clamp x min max)
;; (cond ((< x min) min)
;; ((> x max) max)
;; (else x))))
(define-module (math)
#:pure
#:use-module (scheme base)