hanseitest
Fri May 16 11:53:59+0200 2025
This work is licensed under a Creative Commons Attribution-ShareAlike 4.0 International License
Fri May 16 11:53:59+0200 2025
This work is licensed under a Creative Commons Attribution-ShareAlike 4.0 International License
Tests summary
((ran 6) (failed 0))
Quoting from [1]:
❝
Broadly speaking, probabilistic programming languages are to express computations with degrees of uncertainty, which comes from the imprecision in input data, lack of the complete knowledge or is inherent in the domain. More precisely, the goal of probabilistic programming languages is to represent and automate reasoning about probabilistic models, which describe uncertain quantities -- random variables -- and relationships among them.
Here we focus on the dsl Hansei [2] and the corresponding published paper [3], by Oleg Kiselyov and Chung-chieh Shan; moreover, an application to logic can be found in [4].
The first implementation of our language uses the probability
monad that represents a stochastic computation as a lazy search
tree. That is, our implementation uses the type constructor pV defined below.
type 'a vc = V of 'a | C of (unit -> 'a pV) and 'a pV = (prob * 'a vc) list[(p, V v)] denotes a deterministic successful outcomevwith the
probability mass p. A branch of the form V v is a leaf node
that describes a possible successful outcome, whereas a branch
of the form C thunk is not yet explored.
The intended meaning of a search tree of type 'a pV is a discrete probability distribution over values of type 'a.
(module
hansei
*
(import
scheme
(chicken base)
(chicken continuation)
(chicken pretty-print)
(chicken fixnum)
(chicken sort)
srfi-69
aux)
(define op/times (make-parameter *))
(define op/plus (make-parameter +))
(define op/subtract (make-parameter -))
(define op/divide (make-parameter (λ (m n) (exact->inexact (/ m n)))))
(define op/greater (make-parameter >))
(define-syntax
probcc-τ
(syntax-rules () ((_ p body ...) `((C ,(τ body ...)) ,p))))
(define (probcc-value p v) `((V ,v) ,p))
(define-syntax
let1/probccpair
(syntax-rules
()
((_ ((slot p) probpairexpr) body ...)
(let* ((probpair probpairexpr)
(slot (car probpair))
(p (cadr probpair)))
body
...))))
(define-syntax
cond/probccslot
(syntax-rules
(V C)
((_ slotexpr ((V v) vbody ...) ((C t) cbody ...))
(let* ((slot slotexpr) (flag (car slot)) (payload (cadr slot)))
(cond ((equal? flag 'V) (let1 (v payload) vbody ...))
((equal? flag 'C) (let1 (t payload) cbody ...))
(else (error `(not a probability slot ,slot))))))))
(define (probcc-explore maxdepth choices)
(letrec ((times (op/times))
(plus (op/plus))
(loop (λ (p depth down choices ans susp)
(cond ((null? choices) susp)
(else
(let1/probccpair
((slot pt) (car choices))
(let* ((p*pt (times p pt))
(A (λ (w) (plus w p*pt)))
(rest (cdr choices)))
(cond/probccslot
slot
((V v)
(hash-table-update!/default ans v A 0)
(loop p depth down rest ans susp))
((C t)
(cond (down
(loop p
depth
down
rest
ans
(loop p*pt
(add1 depth)
(< depth maxdepth)
(t)
ans
susp)))
(else
(let1 (s (cons (probcc-τ p*pt (t)) susp))
(loop p depth down rest ans s)))))))))))))
(let* ((ans (make-hash-table))
(susp (loop 1 0 #t choices ans '()))
(f (λ (v p l) (cons (probcc-value p v) l)))
(folded (hash-table-fold ans f susp))
(greater (op/greater)))
(sort folded (λ (a b) (greater (cadr a) (cadr b)))))))
(define (probcc-next-value choices)
(cond ((null? choices) '())
(else
(let1/probccpair
((slot pt) (car choices))
(cond/probccslot
slot
((V v) choices)
((C t)
(let1 (times (op/times))
(probcc-next-value
(append
(cdr choices)
(letmap
((pair (t)))
(let1/probccpair
((slot p) pair)
`(,slot ,(times p pt)))))))))))))
(define (probcc-normalize choices)
(let* ((divide (op/divide))
(plus (op/plus))
(tot (foldr (λ (each t) (plus t (cadr each))) 0 choices))
(N (λ (each) (list (car each) (divide (cadr each) tot)))))
(map N choices)))
(define (probcc-distribution distribution)
(letcc/shift
k
(letmap
((pair distribution))
(letcar&cdr (((v p) pair)) (probcc-τ (car p) (k v))))))
(define (probcc-reflect choices)
(letcc/shift
k
(letrec ((make-choices (λ (pv) (map f pv)))
(f (λ (probpair)
(let1/probccpair
((slot p) probpair)
(cond/probccslot
slot
((V v) (probcc-τ p (k v)))
((C t) (probcc-τ p (make-choices (t)))))))))
(make-choices choices))))
(define (probcc-impossible) (probcc-distribution '()))
(define (probcc-unit v) (list (probcc-value 1 v)))
(define (probcc-bernoulli t f p)
(probcc-distribution `((,t ,p) (,f ,((op/subtract) 1 p)))))
(define (probcc-coin p) (probcc-bernoulli #t #f p))
(define (probcc-uniform n)
(cond ((equal? n 1) 0)
((> n 1)
(letrec ((p (/ 1 n))
(plus (op/plus))
(subtract (op/subtract))
(loop (λ (pacc acc i)
(if (zero? i)
(probcc-distribution
(cons `(,i ,(subtract 1 pacc)) acc))
(loop (plus pacc p) (cons `(,i ,p) acc) (sub1 i))))))
(loop 0 '() (sub1 n))))
(else (error `(non-positive count ,n)))))
(define (probcc-uniform/range low high)
(+ low (probcc-uniform (add1 (- high low)))))
(define (probcc-geometric p s f)
(letrec ((subtract (op/subtract))
(loop (λ (n)
(list (probcc-τ p (list (probcc-value 1 (cons s n))))
(probcc-τ (subtract 1 p) (loop (cons f n)))))))
(probcc-reflect (loop '()))))
(define-syntax
probcc-when
(syntax-rules
()
((_ test body ...) (cond (test body ...) (else (probcc-impossible))))))
(define (probcc-reify/0 model) (resetcc (probcc-unit (model))))
(define ((probcc-reify depth) model)
(probcc-explore depth (probcc-reify/0 model)))
(define probcc-reify/exact/a (probcc-reify +inf.0))
(define-syntax
probcc-reify/exact
(syntax-rules () ((_ body ...) (probcc-reify/exact/a (τ body ...)))))
(define (probcc-variable-elimination f)
(λ args (probcc-reflect (probcc-reify/exact (apply f args)))))
(define-syntax
λ-probcc-bucket
(syntax-rules
()
((_ args body ...)
(letrec ((f (λ args body ...))
(bucket (λ-memo bargs (probcc-reify/exact (apply f bargs)))))
(o probcc-reflect bucket)))))
(define (probcc-leaves choices)
(letrec ((L (λ (choices count)
(let1 (F (λ (probpair acc)
(let1/probccpair
((slot p) probpair)
(cond/probccslot
slot
((V v) (add1 acc))
((C t) (L (t) acc))))))
(foldr F count choices)))))
(L choices 0)))
(define (probcc-dfs choices)
(letmap
((probpair choices))
(let1/probccpair
((slot p) probpair)
(cond/probccslot
slot
((V v) (list probpair))
((C t)
(apply append
(probcc-dfs
(letmap
((inner (t)))
(let1/probccpair
((slot pi) inner)
(list slot ((op/times) p pi))))))))))))
test/procc/coin-model: passJoint distribution of tossing two biased coins, where head has probability 0.6 to appear.
(define (test/procc/coin-model _)
(⊦= '(((V ((x #t) (y #t))) 0.36)
((V ((x #t) (y #f))) 0.24)
((V ((x #f) (y #t))) 0.24)
((V ((x #f) (y #f))) 0.16))
(probcc-normalize
(probcc-reify/exact
(let* ((p 0.6) (x (probcc-coin p)) (y (probcc-coin p)))
`((x ,x) (y ,y)))))))
((eta 0.0) (memory #(6291456 1066528 1048576)) (stdout "") (stderr ""))
test/procc/coin-model/when: passSlightly variation of the previous test, here it has been observed that at least one head appeared.
(define (test/procc/coin-model/when _)
(⊦= '(((V (#t #t)) 0.428571428571429)
((V (#t #f)) 0.285714285714286)
((V (#f #t)) 0.285714285714286))
(probcc-normalize
(probcc-reify/exact
(let* ((p 0.6) (x (probcc-coin p)) (y (probcc-coin p)))
(probcc-when (or x y) (list x y)))))))
((eta 0.0) (memory #(6291456 1067728 1048576)) (stdout "") (stderr ""))
test/procc/grass-model: pass❝
The canonical example is the grass model, with three random variables representing the events of rain, of a switched-on sprinkler and wet grass. The (a priori) probabilities of the first two events are judged to be 30% and 50% correspondingly. Probabilities are non-negative real numbers that may be regarded as weights on non-deterministic choices. Rain almost certainly (90%) wets the grass. The sprinkler also makes the grass wet, in 80% of the cases. The grass may also be wet for some other reason. The modeler gives such an unaccounted event 10% of a chance. This model is often depicted as a directed acyclic graph (DAG) -- so-called Bayesian, or belief network -- with nodes representing random variables and edges conditional dependencies. Associated with each node is a distribution (such as Bernoulli distribution: the flip of a biased coin), or a function that computes a distribution from the node's inputs (such as the noisy disjunction nor). The sort of reasoning we wish to perform on the model is finding out the probability distribution of some of its random variables. For example, we can work out from the model that the probability of the grass being wet is 60.6%. Such reasoning is called probabilistic inference. Often we are interested in the distribution conditioned on the fact that some random variables have been observed to hold a particular value. In our example, having observed that the grass is wet, we want to find out the chance it was raining on that day.
The solution to this problem shows the probability distribution of raining, provided that has been observed a wet grass:
(((V (rain #f)) 0.53152855727963) ((V (rain #t)) 0.46847144272037))
(define (test/procc/grass-model _)
(define result
(probcc-reify/exact
(let* ((rain (probcc-coin 0.3))
(sprinkler (probcc-coin 0.5))
(grass-is-wet
(or (and (probcc-coin 0.9) rain)
(and (probcc-coin 0.8) sprinkler)
(probcc-coin 0.1))))
(probcc-when grass-is-wet `(rain ,rain)))))
(⊦= (list (probcc-value 0.322 '(rain #f)) (probcc-value 0.2838 '(rain #t)))
result))
((eta 0.0) (memory #(6291456 1069512 1048576)) (stdout "") (stderr ""))
test/procc/grass-model/complete: passIf we remove the assumption that has been observed a wet grass, then we have the joint probability distribution of all variables:
(define (test/procc/grass-model/complete _)
(define result
(probcc-reify/exact
(let* ((rain (probcc-coin 0.3))
(sprinkler (probcc-coin 0.5))
(grass-is-wet
(or (and (probcc-coin 0.9) rain)
(and (probcc-coin 0.8) sprinkler)
(probcc-coin 0.1))))
`((rain ,rain) (sprinkler ,sprinkler) (grass-is-wet ,grass-is-wet)))))
(⊦= '(((V ((rain #f) (sprinkler #f) (grass-is-wet #f))) 0.315)
((V ((rain #f) (sprinkler #t) (grass-is-wet #t))) 0.287)
((V ((rain #t) (sprinkler #t) (grass-is-wet #t))) 0.1473)
((V ((rain #t) (sprinkler #f) (grass-is-wet #t))) 0.1365)
((V ((rain #f) (sprinkler #t) (grass-is-wet #f))) 0.063)
((V ((rain #f) (sprinkler #f) (grass-is-wet #t))) 0.035)
((V ((rain #t) (sprinkler #f) (grass-is-wet #f))) 0.0135)
((V ((rain #t) (sprinkler #t) (grass-is-wet #f))) 0.0027))
result)
(⊦= (probcc-normalize result) result))
((eta 0.0) (memory #(6291456 1071072 1048576)) (stdout "") (stderr ""))
test/uniform/range: pass(define (test/uniform/range _)
(⊦= '(((V 1) 1/8)
((V 2) 1/8)
((V 3) 1/8)
((V 4) 1/8)
((V 5) 1/8)
((V 6) 1/8)
((V 7) 1/8)
((V 8) 1/8))
(sort (probcc-reify/exact (probcc-uniform/range 1 8))
(λ (a b) (< (cadr (car a)) (cadr (car b)))))))
((eta 0.0) (memory #(6291456 1072240 1048576)) (stdout "") (stderr ""))
test/geometric: pass(define (test/geometric _)
(define result ((probcc-reify 5) (τ (probcc-geometric 0.85 's 'f))))
(define t6 (cadr (car (sixth result))))
(define t7 (cadr (car (seventh result))))
(define t8 (cadr (car (eighth result))))
(⊦= `(((V (s)) 0.85)
((V (s f)) 0.1275)
((V (s f f)) 0.019125)
((V (s f f f)) 0.00286875)
((V (s f f f f)) 0.0004303125)
((C ,t6) 6.4546875e-05)
((C ,t7) 9.68203125000001e-06)
((C ,t8) 1.70859375e-06))
result))
((eta 0.0) (memory #(6291456 1076400 1048576)) (stdout "") (stderr ""))