Splat a bunch of modules from elsewhere.
This commit is contained in:
parent
7d728559d0
commit
1b950264d1
11 changed files with 3861 additions and 376 deletions
4
game.js
4
game.js
|
@ -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
294
game.scm
|
@ -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
43
modules/goblins/abstract-types.scm
Normal 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
237
modules/goblins/core-types.scm
Normal 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
2370
modules/goblins/core.scm
Normal file
File diff suppressed because it is too large
Load diff
239
modules/goblins/ghash.scm
Normal file
239
modules/goblins/ghash.scm
Normal 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
65
modules/guile/list.scm
Normal 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
48
modules/ice-9/control.scm
Normal 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
171
modules/ice-9/q.scm
Normal 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
595
modules/ice-9/vlist.scm
Normal 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
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Reference in a new issue