├── .gitignore ├── README.md ├── bin ├── cosh ├── cosh.tpl └── utils │ ├── __init__.py │ └── optfunc.py ├── cosh.ss ├── cosh ├── abort.ss ├── application.ss ├── components.ss ├── continuation.ss ├── desugar.ss ├── dot.ss ├── global.ss ├── graph.ss ├── header.ss ├── marg.ss ├── polycommon.ss ├── polygraph.ss ├── polymap.ss ├── polymarg.ss ├── preamble.ss └── visualize.ss ├── docs └── concepts.md └── tests ├── forcing-from-above.church ├── marginalize.church ├── pragmatics.church ├── simple-rejection.church └── stack-recursion.church /.gitignore: -------------------------------------------------------------------------------- 1 | *.pyc 2 | *.out 3 | *.tmp 4 | *~ 5 | \#* 6 | *.gen 7 | \.\#* 8 | *mail.txt -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cosh 2 | 3 | Cosh is an experimental Church implementation that uses dynamic programming based on hashing factored continuations. 4 | 5 | *Cosh is deprecated. If you are looking to write probabilistic programs in Scheme syntax, [webchurch](http://github.com/probmods/webchurch) is your best bet. You can use it online at [probmods.org](http://probmods.org), or on your computer via nodejs. If you are not tied to Scheme syntax, I recommend [webppl](http://webppl.org), our most recent probabilistic programming language. webppl is significantly faster than previous implementations, and additionally supports particle filtering and best-first enumeration inference strategies.* 6 | 7 | ## Installation 8 | 9 | This installation assumes that you have [git](http://git-scm.com/) and a R6RS Scheme installed. The [instructions on the Church wiki](http://projects.csail.mit.edu/church/wiki/Installing_Bher) describe how to install [Vicare Scheme](https://github.com/marcomaggi/vicare) with foreign function interface enabled. 10 | 11 | 1. Install [scheme-tools](https://github.com/stuhlmueller/scheme-tools): 12 | 13 | 1. Clone the scheme-tools repository using git clone git://github.com/stuhlmueller/scheme-tools.git. 14 | 15 | 2. Add the scheme-tools directory to your $VICARE_LIBRARY_PATH. 16 | 17 | To add a directory to your $VICARE_LIBRARY_PATH, change into the directory and type echo -e "\nexport VICARE_LIBRARY_PATH=\`pwd\`:\$VICARE_LIBRARY_PATH" >> ~/.bashrc. Replace ~/.bashrc with the location of your shell config file. 18 | 19 | 3. Add the scheme-tools/bin directory to your $PATH. 20 | 21 | To add a directory to your $PATH, cd into the directory and type echo -e "\nexport PATH=\`pwd\`:\$PATH" >> ~/.bashrc. 22 | 23 | 2. Install [scheme-transforms](https://github.com/stuhlmueller/scheme-transforms): 24 | 25 | 1. Clone the repository using git clone git://github.com/stuhlmueller/scheme-transforms.git. 26 | 27 | 2. Add the scheme-transforms directory to your $VICARE_LIBRARY_PATH (see above). 28 | 29 | 3. Install [cosh](https://github.com/stuhlmueller/cosh): 30 | 31 | 1. Clone the repository using git clone git://github.com/stuhlmueller/cosh.git. 32 | 33 | 2. Add the cosh directory to your $VICARE_LIBRARY_PATH (see above). 34 | 35 | 3. Add the cosh/bin directory to your $PATH (see above). 36 | 37 | 4. Reload your shell config file, e.g., via source ~/.bashrc. 38 | 39 | ## Usage 40 | 41 | Create a file called myprogram.church with the following content: 42 | 43 | (rejection-query 44 | (define x (flip)) 45 | (define y (flip)) 46 | (list x y) 47 | (or x y)) 48 | 49 | Then, on the command line, type: 50 | 51 | cosh myprogram.church 52 | 53 | You should see the following output: 54 | 55 | (#f #t): 0.3333333333333332 (-1.09861228866811) 56 | (#t #f): 0.3333333333333332 (-1.09861228866811) 57 | (#t #t): 0.3333333333333332 (-1.09861228866811) 58 | 59 | This shows the probability (and log probability) of each possible program return value. 60 | 61 | ## Options 62 | 63 | $ cosh --help 64 | Usage: cosh [options] 65 | 66 | Options: 67 | -h, --help show this help message and exit 68 | -d, --debug run all scheme commands in debug mode 69 | -k, --keep do not delete compiled file 70 | -l LIMIT, --limit=LIMIT 71 | restrict graph size 72 | -v, --verbose display all executed commands 73 | -t, --time record runtime 74 | -------------------------------------------------------------------------------- /bin/cosh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | import os, sys, commands, re 3 | from subprocess import Popen 4 | from utils import optfunc 5 | from os.path import abspath, dirname, join, exists 6 | from datetime import datetime 7 | 8 | def vprint(s, verbose): 9 | if verbose: 10 | print 11 | print s 12 | 13 | def call(cmd, verbose=False, allow_fail=False): 14 | if verbose: 15 | print cmd 16 | p = Popen(cmd, shell=True) 17 | p.communicate() 18 | status = p.returncode 19 | if status != 0 and not allow_fail: 20 | print "command failed:\n%s" % cmd 21 | exit() 22 | else: 23 | return status 24 | 25 | def parse_params(params): 26 | if params == "": 27 | return [(None, None)] 28 | else: 29 | key, vals = params.split(":") 30 | return [(key, val) for val in vals.split(",")] 31 | 32 | def val_string(obj): 33 | if type(obj) == str and obj.isdigit(): 34 | return int(obj) 35 | elif obj: 36 | return "#t" 37 | else: 38 | return "#f" 39 | 40 | def param_string(params): 41 | s = "" 42 | for (key, val) in params.items(): 43 | s += " '%s %s " % (key, val_string(val)) 44 | return s 45 | 46 | def get_scheme_command(): 47 | """ 48 | Check whether vicare or ikarus scheme are available and return 49 | appropriate command. 50 | """ 51 | scheme_commands = ["vicare", "ikarus"] 52 | for scheme_command in scheme_commands: 53 | out = commands.getoutput("which %s" % scheme_command).strip() 54 | if out: 55 | return out 56 | return False 57 | 58 | LOAD_PATTERN = r"(\(load\s+\"([^\"]+)\"\s*\))" 59 | 60 | def inline(fn, paths): 61 | """ 62 | Recursively inline all occurrences of (load "filename") in the 63 | file named "fn", searching all paths in the variable "paths", and 64 | return the inlined file contents. 65 | """ 66 | for path in paths: 67 | fp = join(path, fn) 68 | if exists(fp): 69 | s = open(fp).read() 70 | break 71 | for (sexp, fn2) in re.findall(LOAD_PATTERN, s): 72 | paths2 = [abspath(dirname(fn2))] + paths 73 | s = s.replace(sexp, inline(fn2, paths2)) 74 | return s 75 | 76 | @optfunc.main 77 | @optfunc.arghelp('limit', 'restrict graph size') 78 | @optfunc.arghelp('verbose', 'display all executed commands') 79 | @optfunc.arghelp('debug', 'run all scheme commands in debug mode') 80 | @optfunc.arghelp('time', 'record runtime') 81 | @optfunc.arghelp('set', 'run church file with multiple parameter settings') 82 | @optfunc.arghelp('keep', 'do not delete compiled file') 83 | def main(file, limit="", verbose=False, debug=False, time=False, keep=False, set=""): 84 | """Usage: %prog [options]""" 85 | params = parse_params(set) 86 | in_path = abspath(file) 87 | cosh_path = abspath(dirname(sys.argv[0])) 88 | settings = { 89 | "debug" : debug and "--debug" or "", 90 | "out_path" : in_path + ".tmp", 91 | "cosh_path" : cosh_path 92 | } 93 | 94 | scheme_command = get_scheme_command() 95 | settings["scheme_bin"] = scheme_command 96 | if not scheme_command: 97 | print "Could not find vicare or ikarus!" 98 | exit() 99 | 100 | for (i, (param_key, param_value)) in enumerate(params): 101 | 102 | vprint("Generating scheme code ...", verbose) 103 | code = inline(in_path, [abspath(dirname(file))]) 104 | 105 | if param_key: 106 | vprint("* %s: %s" % (param_key, param_value), True) 107 | code = code % { param_key : param_value } 108 | 109 | params = { 110 | "limit" : limit, 111 | "verbosity" : verbose 112 | } 113 | 114 | template = open(os.path.join(cosh_path, "cosh.tpl")).read() 115 | generated = template % { "code" : code, 116 | "cosh-params" : param_string(params), 117 | "verbose" : val_string(verbose)} 118 | 119 | f = open(settings["out_path"], "w") 120 | f.write(generated) 121 | f.close() 122 | 123 | vprint("Running generated scheme in %s ...\n" % scheme_command, verbose) 124 | pre = datetime.now() 125 | call("%(scheme_bin)s %(debug)s --r6rs-script '%(out_path)s'\n" % settings, verbose) 126 | post = datetime.now() 127 | 128 | if time: 129 | delta = post-pre 130 | seconds = delta.seconds + delta.microseconds/1000000.0 131 | print("Runtime: %fs" % seconds) 132 | 133 | if not keep: 134 | vprint("Removing compiled file ...", verbose) 135 | call("rm -f '%(out_path)s'" % settings, verbose) 136 | 137 | -------------------------------------------------------------------------------- /bin/cosh.tpl: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (import (rnrs) 4 | (scheme-tools) 5 | (cosh)) 6 | 7 | (define expr 8 | '( 9 | %(code)s 10 | 11 | )) 12 | 13 | (define marginal->value car) 14 | (define marginal->log-prob cdr) 15 | (let ([marginals (cosh expr %(cosh-params)s)]) 16 | (for-each (lambda (marginal) 17 | (pe (marginal->value marginal) ": " 18 | (exp (marginal->log-prob marginal)) 19 | " (" (marginal->log-prob marginal) ")\n")) 20 | marginals) 21 | (when %(verbose)s 22 | (pe "\nsum: " (exp (apply logsumexp (map marginal->log-prob marginals))) "\n"))) -------------------------------------------------------------------------------- /bin/utils/__init__.py: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stuhlmueller/cosh/2ff88fa89a92e6abd73072ff8036a7c6d2f24fd6/bin/utils/__init__.py -------------------------------------------------------------------------------- /bin/utils/optfunc.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | 3 | # Copyright (c) 2009, Simon Willison 4 | # All rights reserved. 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions are met: 8 | # 9 | # * Redistributions of source code must retain the above copyright notice, this 10 | # list of conditions and the following disclaimer. 11 | # 12 | # * Redistributions in binary form must reproduce the above copyright notice, 13 | # this list of conditions and the following disclaimer in the documentation 14 | # and/or other materials provided with the distribution. 15 | # 16 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE 20 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | 27 | from optparse import OptionParser, make_option 28 | import sys, inspect, re 29 | 30 | single_char_prefix_re = re.compile('^[a-zA-Z0-9]_') 31 | 32 | class ErrorCollectingOptionParser(OptionParser): 33 | def __init__(self, *args, **kwargs): 34 | self._errors = [] 35 | self._custom_names = {} 36 | # can't use super() because OptionParser is an old style class 37 | OptionParser.__init__(self, *args, **kwargs) 38 | 39 | def parse_args(self, argv): 40 | options, args = OptionParser.parse_args(self, argv) 41 | for k,v in options.__dict__.iteritems(): 42 | if k in self._custom_names: 43 | options.__dict__[self._custom_names[k]] = v 44 | del options.__dict__[k] 45 | return options, args 46 | 47 | def error(self, msg): 48 | self._errors.append(msg) 49 | 50 | def func_to_optionparser(func): 51 | args, varargs, varkw, defaultvals = inspect.getargspec(func) 52 | defaultvals = defaultvals or () 53 | options = dict(zip(args[-len(defaultvals):], defaultvals)) 54 | argstart = 0 55 | if func.__name__ == '__init__': 56 | argstart = 1 57 | if defaultvals: 58 | required_args = args[argstart:-len(defaultvals)] 59 | else: 60 | required_args = args[argstart:] 61 | 62 | # Build the OptionParser: 63 | opt = ErrorCollectingOptionParser(usage = func.__doc__) 64 | 65 | helpdict = getattr(func, 'optfunc_arghelp', {}) 66 | 67 | # Add the options, automatically detecting their -short and --long names 68 | shortnames = set(['h']) 69 | for funcname, example in options.items(): 70 | # They either explicitly set the short with x_blah... 71 | name = funcname 72 | if single_char_prefix_re.match(name): 73 | short = name[0] 74 | name = name[2:] 75 | opt._custom_names[name] = funcname 76 | # Or we pick the first letter from the name not already in use: 77 | else: 78 | for short in name: 79 | if short not in shortnames: 80 | break 81 | 82 | shortnames.add(short) 83 | short_name = '-%s' % short 84 | long_name = '--%s' % name.replace('_', '-') 85 | if example in (True, False, bool): 86 | action = 'store_true' 87 | else: 88 | action = 'store' 89 | opt.add_option(make_option( 90 | short_name, long_name, action=action, dest=name, default=example, 91 | help = helpdict.get(funcname, '') 92 | )) 93 | 94 | return opt, required_args 95 | 96 | def resolve_args(func, argv): 97 | parser, required_args = func_to_optionparser(func) 98 | options, args = parser.parse_args(argv) 99 | 100 | # Special case for stdin/stdout/stderr 101 | for pipe in ('stdin', 'stdout', 'stderr'): 102 | if pipe in required_args: 103 | required_args.remove(pipe) 104 | setattr(options, 'optfunc_use_%s' % pipe, True) 105 | 106 | # Do we have correct number af required args? 107 | if len(required_args) != len(args): 108 | if not hasattr(func, 'optfunc_notstrict'): 109 | parser._errors.append('Required %d arguments, got %d' % ( 110 | len(required_args), len(args) 111 | )) 112 | 113 | # Ensure there are enough arguments even if some are missing 114 | args += [None] * (len(required_args) - len(args)) 115 | for i, name in enumerate(required_args): 116 | setattr(options, name, args[i]) 117 | 118 | return options.__dict__, parser._errors 119 | 120 | def run( 121 | func, argv=None, stdin=sys.stdin, stdout=sys.stdout, stderr=sys.stderr 122 | ): 123 | argv = argv or sys.argv[1:] 124 | include_func_name_in_errors = False 125 | 126 | # Handle multiple functions 127 | if isinstance(func, (tuple, list)): 128 | funcs = dict([ 129 | (fn.__name__, fn) for fn in func 130 | ]) 131 | try: 132 | func_name = argv.pop(0) 133 | except IndexError: 134 | func_name = None 135 | if func_name not in funcs: 136 | names = ["'%s'" % fn.__name__ for fn in func] 137 | s = ', '.join(names[:-1]) 138 | if len(names) > 1: 139 | s += ' or %s' % names[-1] 140 | stderr.write("Unknown command: try %s\n" % s) 141 | return 142 | func = funcs[func_name] 143 | include_func_name_in_errors = True 144 | 145 | if inspect.isfunction(func): 146 | resolved, errors = resolve_args(func, argv) 147 | elif inspect.isclass(func): 148 | if hasattr(func, '__init__'): 149 | resolved, errors = resolve_args(func.__init__, argv) 150 | else: 151 | resolved, errors = {}, [] 152 | else: 153 | raise TypeError('arg is not a Python function or class') 154 | 155 | # Special case for stdin/stdout/stderr 156 | for pipe in ('stdin', 'stdout', 'stderr'): 157 | if resolved.pop('optfunc_use_%s' % pipe, False): 158 | resolved[pipe] = locals()[pipe] 159 | 160 | if not errors: 161 | try: 162 | return func(**resolved) 163 | except Exception, e: 164 | if include_func_name_in_errors: 165 | stderr.write('%s: ' % func.__name__) 166 | stderr.write(str(e) + '\n') 167 | else: 168 | if include_func_name_in_errors: 169 | stderr.write('%s: ' % func.__name__) 170 | stderr.write("%s\n" % '\n'.join(errors)) 171 | 172 | def main(*args, **kwargs): 173 | prev_frame = inspect.stack()[-1][0] 174 | mod = inspect.getmodule(prev_frame) 175 | if mod is not None and mod.__name__ == '__main__': 176 | run(*args, **kwargs) 177 | return args[0] # So it won't break anything if used as a decorator 178 | 179 | # Decorators 180 | def notstrict(fn): 181 | fn.optfunc_notstrict = True 182 | return fn 183 | 184 | def arghelp(name, help): 185 | def inner(fn): 186 | d = getattr(fn, 'optfunc_arghelp', {}) 187 | d[name] = help 188 | setattr(fn, 'optfunc_arghelp', d) 189 | return fn 190 | return inner 191 | -------------------------------------------------------------------------------- /cosh.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh) 6 | 7 | (export cosh 8 | marg-expr 9 | marg-cc-cps-thunk 10 | marg-graph 11 | polymarg-expr 12 | polymarg-return-thunk 13 | polymarg-graph 14 | compmarg-expr 15 | expr->graph 16 | expr->cc-cps-thunk 17 | expr->return-thunk 18 | expr->cc-cps-expr 19 | cc-cps-thunk->graph 20 | return-thunk->polygraph 21 | header->reserved-words) 22 | 23 | (import (rnrs) 24 | (rnrs eval) 25 | (transforms) 26 | (cosh dot) 27 | (cosh marg) 28 | (cosh global) 29 | (cosh graph) 30 | (cosh polymarg) 31 | (cosh polycommon) 32 | (cosh polygraph) 33 | (cosh polymap) 34 | (cosh components) 35 | (cosh desugar) 36 | (cosh header) 37 | (cosh preamble) 38 | (scheme-tools) 39 | (scheme-tools graph) 40 | (scheme-tools graph utils) 41 | (scheme-tools graph components) 42 | (scheme-tools macros) 43 | (scheme-tools math) 44 | (scheme-tools srfi-compat :1) 45 | (transforms syntax) 46 | (xitomatl keywords)) 47 | 48 | (define (header->reserved-words header) 49 | (let ([defines (filter (lambda (e) (tagged-list? e 'define)) header)]) 50 | (map (lambda (d) (if (list? (second d)) (caadr d) (second d))) 51 | defines))) 52 | 53 | (define (expr->environment expr) 54 | (let ([imports (find (lambda (e) (tagged-list? e 'import)) expr)]) 55 | (apply environment (rest imports)))) 56 | 57 | (define (expr->body expr) 58 | (filter (lambda (e) (not (tagged-list? e 'import))) 59 | expr)) 60 | 61 | (define (evaluate expr) 62 | (eval (local (begin-wrap (expr->body expr))) 63 | (expr->environment expr))) 64 | 65 | ;; linear solver 66 | 67 | (define (expr->cc-cps-expr header expr with-returns) 68 | `(,@header 69 | (lambda () 70 | ,(transform (de-sugar-toplevel expr) 71 | (header->reserved-words header) 72 | with-returns)))) 73 | 74 | ;; (header, expr) -> thunk 75 | (define (expr->cc-cps-thunk header expr) 76 | (evaluate (expr->cc-cps-expr header expr #f))) 77 | 78 | ;; (header, expr) -> graph 79 | (define expr->graph 80 | ($ cc-cps-thunk->graph 81 | expr->cc-cps-thunk)) 82 | 83 | ;; (thunk, graph-size-limit) -> dist 84 | (define (marg-cc-cps-thunk cc-cps-thunk graph-size-limit) 85 | (marg-graph 86 | (cc-cps-thunk->graph cc-cps-thunk graph-size-limit))) 87 | 88 | ;; (header, expr) -> dist 89 | (define (marg-expr header expr graph-size-limit) 90 | (verbose-pe "\nTIME:\n") 91 | (let* ([cc-cps-thunk (opt-timeit (verbose) (expr->cc-cps-thunk header expr))] 92 | [graph (opt-timeit (verbose) (cc-cps-thunk->graph cc-cps-thunk graph-size-limit))] 93 | [original-graph-size (graph-size graph)] 94 | [marginals (opt-timeit (verbose) (marg-graph graph))]) 95 | (verbose-pe "\nSPACE:\n" 96 | "- graph-size: " original-graph-size "\n") 97 | marginals)) 98 | 99 | 100 | ;; polynomial solver 101 | 102 | ;; (header, expr) -> thunk 103 | (define (expr->return-thunk header expr) 104 | (evaluate (expr->cc-cps-expr header expr #t))) 105 | 106 | ;; (thunk, graph-size-limit) -> dist 107 | (define polymarg-return-thunk 108 | ($ polymarg-graph 109 | return-thunk->polygraph)) 110 | 111 | ;; (expr, graph-size-limit) -> dist 112 | (define (polymarg-expr header expr graph-size-limit) 113 | (polymarg-return-thunk (expr->return-thunk header expr) 114 | graph-size-limit)) 115 | 116 | 117 | ;; component solver 118 | 119 | (define (get-component-sizes graph components) 120 | (map (lambda (comp) 121 | (apply + (map (lambda (root) (length (subgraph->equations graph root))) 122 | comp))) 123 | components)) 124 | 125 | ;; expr -> dist 126 | (define (compmarg-expr header expr graph-size-limit) 127 | (verbose-pe "\nTIME:\n") 128 | (let* ([return-thunk (opt-timeit (verbose) (expr->return-thunk header expr))] 129 | [graph (opt-timeit (verbose) (return-thunk->polygraph return-thunk graph-size-limit))] 130 | [original-graph-size (graph-size graph)] 131 | [polymap (opt-timeit (verbose) (polygraph->polymap graph))] 132 | [components (opt-timeit (verbose) (strongly-connected-components polymap))] 133 | [marginals (opt-timeit (verbose) (marginalize-components graph components))]) 134 | (let ([component-sizes (get-component-sizes graph components)]) 135 | (verbose-pe "\nSPACE:\n" 136 | "- graph-size: " original-graph-size "\n" 137 | "- subproblems: " (graph-size polymap) "\n" 138 | "- components: " (length components) "\n" 139 | "- mean-component: " (exact->inexact (mean component-sizes)) "\n" 140 | "- median-component: " (exact->inexact (median < component-sizes)) 141 | "\n\n") 142 | (when (verbose) 143 | (polygraph->file graph)) 144 | marginals))) 145 | 146 | 147 | (define (get-solver state-merging subproblems) 148 | (cond [(and (not state-merging) (not subproblems)) (error 'get-solver "enumeration solver not available")] 149 | [(not subproblems) marg-expr] 150 | [else (lambda args (parameterize ([merge-continuations state-merging]) (apply compmarg-expr args)))])) 151 | 152 | (define/kw (cosh expr 153 | [limit :default #f] 154 | [verbosity :default #f] 155 | [state-merging :default #t] 156 | [subproblems :default #t]) 157 | (let ([solver (get-solver state-merging subproblems)]) 158 | (parameterize ([verbose verbosity]) 159 | (solver header 160 | (with-preamble expr) 161 | limit)))) 162 | 163 | ) -------------------------------------------------------------------------------- /cosh/abort.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh abort) 6 | 7 | (export make-abort 8 | abort?) 9 | 10 | (import (rnrs) 11 | (scheme-tools)) 12 | 13 | (define (make-abort) 14 | (list 'abort)) 15 | 16 | (define (abort? obj) 17 | (tagged-list? obj 'abort)) 18 | 19 | ) -------------------------------------------------------------------------------- /cosh/application.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh application) 6 | 7 | (export make-application 8 | application? 9 | call-application-with-cont 10 | call-application-cont 11 | call-application 12 | applications-delimited-equal? 13 | applications-equal? 14 | application:args 15 | application:cont 16 | application:proc 17 | application:delimited-id 18 | application:id) 19 | 20 | (import (rnrs) 21 | (cosh global) 22 | (scheme-tools) 23 | (scheme-tools srfi-compat :1) 24 | (scheme-tools deepcopy) 25 | (scheme-tools object-id)) 26 | 27 | (define (make-application proc cont . args) 28 | (let ([app-id (if (merge-continuations) 'app (gensym))]) 29 | (when (not (vector? proc)) 30 | (begin 31 | (pe "Error: Tried to apply non-procedure object. Entering REPL ...\n") 32 | (repl proc cont args))) 33 | (list 'application 34 | (object->id (list app-id proc cont args)) 35 | (object->id (list proc args))))) 36 | 37 | (define (application? obj) 38 | (tagged-list? obj 'application)) 39 | 40 | (define application:id second) 41 | 42 | (define application:delimited-id third) 43 | 44 | (define (application:proc c) 45 | (second (id->object (application:id c)))) 46 | 47 | (define (application:cont c) 48 | (third (id->object (application:id c)))) 49 | 50 | (define (application:args c) 51 | (fourth (id->object (application:id c)))) 52 | 53 | (define (applications-equal? c1 c2) 54 | (eq? (application:id c1) 55 | (application:id c2))) 56 | 57 | (define (applications-delimited-equal? c1 c2) 58 | (eq? (application:delimited-id c1) 59 | (application:delimited-id c2))) 60 | 61 | (define (call-application c) 62 | (let ([proc1 (deepcopy (application:proc c))] 63 | [cont1 (deepcopy (application:cont c))] 64 | [args1 (deepcopy (application:args c))]) 65 | (apply (vector-ref proc1 0) 66 | (pair proc1 (pair cont1 args1))))) 67 | 68 | ;; call the cont in application 69 | (define (call-application-cont c val) 70 | (let ([cont1 (deepcopy (application:cont c))] 71 | [val1 (deepcopy val)]) 72 | ((vector-ref cont1 0) cont1 val1))) 73 | 74 | ;; cont is a continuation closure vector 75 | (define (call-application-with-cont c cont) 76 | (let ([proc1 (deepcopy (application:proc c))] 77 | [cont1 (deepcopy cont)] 78 | [args1 (deepcopy (application:args c))]) 79 | ;; (pretty-print proc1) 80 | (apply (vector-ref proc1 0) 81 | (pair proc1 (pair cont1 args1))))) 82 | 83 | ) -------------------------------------------------------------------------------- /cosh/components.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh components) 6 | 7 | (export marginalize-components) 8 | 9 | (import (rnrs) 10 | (cosh visualize) 11 | (scheme-tools srfi-compat :1) 12 | (scheme-tools graph) 13 | (scheme-tools math iterate) 14 | (scheme-tools math newton) 15 | (scheme-tools hash) 16 | (scheme-tools watcher) 17 | (scheme-tools) 18 | (cosh global) 19 | (cosh polymarg) 20 | (cosh polycommon)) 21 | 22 | (define (equation->symbols equation eqn-filter) 23 | (cond [(null? equation) '()] 24 | [(contains? '(= + - * / log exp logsumexp if or) equation eq?) '()] 25 | [(eqn-filter equation) '()] 26 | [(symbol? equation) (list equation)] 27 | [(list? equation) (apply append (map (lambda (eqn) (equation->symbols eqn eqn-filter)) 28 | equation))] 29 | [else '()])) 30 | 31 | (define (equations->symbols equations eqn-filter) 32 | (unique 33 | (fold (lambda (equation symbols) 34 | (append (equation->symbols equation eqn-filter) symbols)) 35 | '() 36 | equations))) 37 | 38 | ;; Filter out duplicate objects 39 | (define (unique objects) 40 | (let ([seen? (make-watcher)]) 41 | (filter (lambda (obj) (not (seen? obj))) objects))) 42 | 43 | ;; Return only those bindings that talk about variables that occur in 44 | ;; the equations. 45 | (define (relevant-solution-equations equations solutions) 46 | (let* ([symbols (equations->symbols equations (lambda (x) #f))] 47 | [equations (filter-map (lambda (symbol) 48 | (let ([binding (hash-table-ref/default solutions symbol #f)]) 49 | (if binding 50 | `(= ,symbol ,binding) 51 | #f))) 52 | symbols)]) 53 | (unique equations))) 54 | 55 | (define (component-equations graph component) 56 | (fold (lambda (node eqns) 57 | (append (subgraph->equations graph node) eqns)) 58 | '() 59 | component)) 60 | 61 | (define (free-variables eqns) 62 | (let ([bound-vars (map second eqns)]) 63 | (equations->symbols (map cddr eqns) 64 | (lambda (s) (contains? bound-vars s eq?))))) 65 | 66 | (define (free-variable-equations eqns) 67 | (map (lambda (var-name) 68 | `(= ,var-name -inf.0)) 69 | (free-variables eqns))) 70 | 71 | (define (hash-table-set!/assert-consistent table key value) 72 | (let* ([hash-table-miss (gensym)] 73 | [existing-value (hash-table-ref/default table key hash-table-miss)]) 74 | (if (eq? existing-value hash-table-miss) 75 | (hash-table-set! table key value) 76 | (when (not (equal? existing-value value)) 77 | (begin (pe " " key " is bound to " existing-value ", can't set to " value "\n") 78 | (error #f "hash-table-set!/assert-unbound: not unbound")))))) 79 | 80 | (define (iterate-with-message equations) 81 | (let-values ([(solutions final-delta) (iterate/eqns equations 0.0)]) 82 | (if (not (= final-delta 0.0)) 83 | (begin 84 | (if verbose 85 | (pen "fixed-point iterator: final delta " final-delta " -- trying newton...") 86 | (pe ".")) 87 | (newton equations)) 88 | solutions))) 89 | 90 | ;; component: a list of polymap nodes (= root nodes for subproblems) 91 | ;; solutions: association list of variable names (?) and values 92 | ;; return value: new solutions 93 | (define (marginalize-component! graph component solutions) 94 | (let* ([equations-1 (component-equations graph component)] 95 | [equations-2 (relevant-solution-equations equations-1 solutions)] 96 | [equations-3 (free-variable-equations (append equations-1 equations-2))] 97 | [equations (append equations-1 equations-2 equations-3)] 98 | [new-solutions (iterate-with-message equations)]) 99 | (for-each (lambda (binding) 100 | (hash-table-set!/assert-consistent solutions 101 | (first binding) 102 | (rest binding))) 103 | new-solutions))) 104 | 105 | ;; Components must be in topological order (i.e. if there is a link 106 | ;; from component A to component B, A must come first). 107 | (define (marginalize-components graph components) 108 | (let ([solutions (make-eq-hash-table)]) 109 | (for-each (lambda (component) (marginalize-component! graph component solutions)) 110 | components) 111 | (lookup-leaf-values graph solutions))) 112 | 113 | ) -------------------------------------------------------------------------------- /cosh/continuation.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; continuations can be compared using "equal?" 4 | 5 | (library 6 | 7 | (cosh continuation) 8 | 9 | (export make-continuation 10 | continuation:id 11 | continuation:closure 12 | continuation:support 13 | continuation:scores 14 | continuation? 15 | continuations-equal? 16 | call-continuation) 17 | 18 | (import (rnrs) 19 | (cosh global) 20 | (scheme-tools) 21 | (scheme-tools srfi-compat :1) 22 | (scheme-tools deepcopy) 23 | (scheme-tools object-id)) 24 | 25 | (define (make-continuation closure support scores) 26 | (let ([cont-id (if (merge-continuations) 'cont (gensym))]) 27 | (list 'cont (object->id (list cont-id closure support scores)) support scores))) 28 | 29 | (define continuation:id second) 30 | 31 | (define (continuation:closure cont) 32 | (second (id->object (continuation:id cont)))) 33 | 34 | (define continuation:support third) 35 | 36 | (define continuation:scores fourth) 37 | 38 | (define (continuation? obj) 39 | (tagged-list? obj 'cont)) 40 | 41 | (define (continuations-equal? c1 c2) 42 | (eq? (continuation:id c1) 43 | (continuation:id c2))) 44 | 45 | (define (call-continuation cont value) 46 | (let ([clos (deepcopy (continuation:closure cont))]) 47 | ((vector-ref clos 0) clos value))) 48 | 49 | ) -------------------------------------------------------------------------------- /cosh/desugar.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; Copied from Bher. 4 | 5 | (library 6 | 7 | (cosh desugar) 8 | 9 | (export de-sugar 10 | de-sugar-all 11 | de-sugar-toplevel 12 | register-sugar! 13 | register-query-sugar) 14 | 15 | (import (rnrs) 16 | (scheme-tools) 17 | (scheme-tools srfi-compat :1)) 18 | 19 | ;;;some syntax utils 20 | (define (mem? sexpr) (tagged-list? sexpr 'mem)) 21 | (define (lambda? exp) (tagged-list? exp 'lambda)) 22 | (define (lambda-parameters exp) (cadr exp)) 23 | (define (lambda-body exp) (caddr exp)) 24 | (define (quoted? exp) (tagged-list? exp 'quote)) 25 | (define (begin? exp) (tagged-list? exp 'begin)) 26 | (define (definition? exp) (tagged-list? exp 'define)) 27 | (define (if? exp) (tagged-list? exp 'if)) 28 | (define (application? exp) (pair? exp)) 29 | (define (letrec? exp) (tagged-list? exp 'letrec)) 30 | 31 | ;;;include paths 32 | (define include-paths (list "./" "include/")) ;;FIXME: include scheme search-path? 33 | ;;(append (list "./" "include/") (map (lambda (search-path) (string-append search-path "/include/")) (search-paths)))) 34 | 35 | ; goes through a list of library paths and opens 36 | ; the first one it finds 37 | (define (open-included-file filename) 38 | (define (loop-through-paths path-list) 39 | (if (null? path-list) 40 | (error "open-included-file" (string-append "File " filename " not found on Cosh include paths.")) 41 | (if (file-exists? (string-append (first path-list) filename)) 42 | (open-input-file (string-append (first path-list) filename)) 43 | (loop-through-paths (rest path-list))))) 44 | (loop-through-paths include-paths)) 45 | 46 | ;;;Gimme some sugar! 47 | 48 | ;;de-sugaring code: 49 | (define sugar-registry '()) 50 | (define (register-sugar! pattern translator . times-to-try) 51 | (set! sugar-registry (cons (list pattern translator times-to-try) sugar-registry)) ) 52 | (define sugar-pattern first) 53 | (define sugar-translator second) 54 | (define times-to-try third) 55 | 56 | (define (de-sugar expr) 57 | (define unchanged (gensym)) 58 | (define (try expr sugar-list) 59 | (if (null? sugar-list) 60 | unchanged 61 | (if ((sugar-pattern (first sugar-list)) expr) 62 | ((sugar-translator (first sugar-list)) expr) 63 | (try expr (rest sugar-list)) ))) 64 | (let loop ((expr expr) 65 | (pass 0)) 66 | (let ((new-expr (try expr (filter (lambda (s) (or (null? (times-to-try s)) (< pass (first (times-to-try s))))) sugar-registry)))) 67 | (if (eq? new-expr unchanged) 68 | expr 69 | (loop new-expr (+ pass 1)) )))) 70 | 71 | (define (de-sugar-all sexpr) 72 | (let ((new-sexpr (de-sugar sexpr))) 73 | (if (list? new-sexpr) 74 | (map de-sugar-all new-sexpr) 75 | new-sexpr))) 76 | 77 | ;; keep begin-defines at top level, desugar within 78 | (define (de-sugar-toplevel sexpr) 79 | (if (begin? sexpr) 80 | (let ([e (expand-loads sexpr)]) 81 | (let-values ([(defines non-defines) (partition-begin e)]) 82 | `(begin 83 | ,@(map de-sugar-all defines) 84 | ,(de-sugar-all (begin-wrap non-defines))))) 85 | (de-sugar-all sexpr))) 86 | 87 | ;; (begin ...) 88 | 89 | (define (begin-wrap exprs) 90 | (if (null? (rest exprs)) 91 | (first exprs) 92 | `(begin ,@exprs))) 93 | 94 | ;; (begin ...) is now a special form! 95 | ;;(define (desugar-begin expr) 96 | ;; (last expr)) 97 | ;;(register-sugar begin? desugar-begin) 98 | 99 | ;; (let (var-bindings) expr1 ... exprN) 100 | (define (let? expr) (and (tagged-list? expr 'let) (list? (second expr)))) 101 | (define (let->lambda expr) 102 | (let* ((bindings (second expr)) 103 | (vars (map first bindings)) 104 | (value-exprs (map second bindings)) 105 | (body (begin-wrap (drop expr 2)))) 106 | `((lambda ,vars ,body) ,@value-exprs) )) 107 | 108 | ;; (let loop (var-bindings) expr1 ... exprN) 109 | 110 | (define (named-let? expr) (and (tagged-list? expr 'let) (symbol? (second expr)))) 111 | 112 | (define (named-let->letrec expr) 113 | `(letrec ((,(second expr) (lambda ,(map first (third expr)) ,(begin-wrap (drop expr 3))))) (,(second expr) ,@(map second (third expr)))) ) 114 | 115 | (define (named-let->lambda expr) 116 | (let* ((proc-name (second expr)) 117 | (let-conversion (let->lambda (rest expr)))) 118 | `((Y (lambda (,proc-name) ,(first let-conversion))) ,@(rest let-conversion)) )) 119 | 120 | ;; (let* ...) 121 | (define (let*? expr) (tagged-list? expr 'let*)) 122 | (define (desugar-let* expr) 123 | (let ((bindings (second expr)) 124 | (body (begin-wrap (drop expr 2)))) 125 | (if (null? bindings) 126 | body 127 | (let* ((binding (first bindings)) 128 | (var (first binding)) 129 | (value-exprs (second binding)) ) 130 | `((lambda (,var) (let* ,(rest bindings) ,body)) ,value-exprs) )))) 131 | 132 | ;; (case ...) 133 | (define (case? expr) (tagged-list? expr 'case)) 134 | (define (desugar-case expr) 135 | (let ((key-symbol (gensym)) 136 | (key-expr (second expr)) 137 | (value-exprs (drop expr 2)) ) 138 | `(let ((,key-symbol ,key-expr)) 139 | (cond ,@(map (lambda (value-expr) 140 | (let ((vals (first value-expr)) 141 | (val-expr (rest value-expr)) ) 142 | (cond ((list? vals) 143 | `((any (list ,@(map (lambda (val) `(equal? ,key-symbol ,val)) vals) )) 144 | ,@val-expr ) ) 145 | ((equal? vals 'else) 146 | `(else ,@val-expr) ) 147 | (else (error "Invalid case expression." vals)) ) )) 148 | value-exprs ))) )) 149 | 150 | ;; (cond ...) 151 | (define (cond? expr) (tagged-list? expr 'cond)) 152 | (define (desugar-cond expr) 153 | (let loop ((conditions (rest expr))) 154 | (if (null? conditions) 155 | '(void) 156 | (let* ((condition (first conditions)) 157 | (test (first condition))) 158 | (if (equal? test 'else) 159 | (if (not (null? (rest conditions))) 160 | (error expr "else clause in cond expression must be last.") 161 | (begin-wrap (rest condition)) ) 162 | `(if ,test 163 | ,(begin-wrap (rest condition)) 164 | ,(loop (rest conditions)) ) ))))) 165 | 166 | ;; (when ...) 167 | (define (when? expr) (tagged-list? expr 'when)) 168 | (define (desugar-when expr) 169 | `(if ,(second expr) 170 | (begin 171 | ,@(cddr expr)) 172 | (void))) 173 | 174 | ;;define sugar: (define (foo x y) ...) 175 | (define (define-fn? expr) (and (tagged-list? expr 'define) (not (symbol? (second expr))))) 176 | (define (desugar-define-fn expr) 177 | (if (define-fn? expr) 178 | (let ((def-var (first (second expr))) 179 | (def-params (rest (second expr))) 180 | (def-body (rest (rest expr)))) 181 | `(define ,def-var (lambda ,def-params ,@def-body))) 182 | expr)) 183 | 184 | ;;load sugar. 185 | (define (seq-with-load? expr) (and (list? expr) 186 | (fold (lambda (subexpr accum) (or (tagged-list? subexpr 'load) accum)) false expr))) 187 | (define (expand-loads expr) 188 | (apply append (map (lambda (subexpr) (if (load? subexpr) (file->list (open-included-file (second subexpr))) (list subexpr))) expr))) 189 | (define (file->list filehandle) 190 | (let ((next (read filehandle))) 191 | (if (eof-object? next) '() (cons next (file->list filehandle))))) 192 | (define (load? expr) (tagged-list? expr 'load)) 193 | 194 | ;; desugar-define-fn here is to make defines be in estandard form. 195 | (define (partition-begin e) 196 | (let* ((defines (map desugar-define-fn (filter (lambda (e) (tagged-list? e 'define)) (rest e)))) 197 | (non-defines (filter (lambda (e) (not (tagged-list? e 'define))) (rest e)))) 198 | (values defines non-defines))) 199 | 200 | ;;we desugar (begin .. define ..) into letrec for this implementation. 201 | (define (begin-defines? sexpr) 202 | (and (tagged-list? sexpr 'begin) (not (null? (filter (lambda (e) (tagged-list? e 'define)) sexpr))))) 203 | (define (desugar-begin-defines sexpr) 204 | (let-values ([(defines non-defines) (partition-begin sexpr)]) 205 | `(letrec ,(map rest defines) ,(begin-wrap non-defines)))) 206 | 207 | ;;normal-form procedure returns a pair of condition-value and query-thunk. query thunk samples from the conditional predictive. 208 | ;; transforms into a def-query that expects church code of 209 | ;; form: (query-name arg1 arg2 ... (define ...) 210 | ;; ... query-expr condition-expr) 211 | ;;note: primitive-name shouldn't be the same as query-name, because otherwise desugarring doesn't know when to stop. 212 | (define (register-query-sugar query-name) 213 | (define (query? expr) (and (tagged-list? expr query-name) 214 | (>= (length (rest expr)) 2))) ;;make sure not to try de-sugaring the definition of the query -- queries have at least two subexprs. 215 | (define (desugar-query expr) 216 | (let*-values ([ (control-part defs) (break (lambda (subexpr) (tagged-list? subexpr 'define)) (drop-right expr 2))] 217 | [ (control-args) (rest control-part)] 218 | [ (query-exp cond-exp) (apply values (take-right expr 2))]) 219 | `(,query-name ,@control-args (lambda () (begin ,@defs (pair ,cond-exp (lambda () ,query-exp)))) ))) 220 | (register-sugar! query? desugar-query 1)) 221 | 222 | ;;psmc-query needs to be handled slightly differently, because the query code gets temps->nfqp which takes 'temperature' arguments then gives the nfqp. 223 | ;;assumes call form (psmc-query ..other-control-args.. ..defines.. ). 224 | (define (tempered-query? query-name expr) 225 | (and (tagged-list? expr query-name) 226 | (>= (length (rest expr)) 2))) ;;make sure not to try de-sugaring the definition of the query -- queries have at least two subexprs. 227 | (define (desugar-tempered-query query-name expr) 228 | (let*-values ([(control-part defs) (break (lambda (subexpr) (tagged-list? subexpr 'define)) (drop-right expr 2))] 229 | [(temp-args) (second control-part)] 230 | [(temps) (third control-part)] 231 | [(control-args) (drop control-part 3)] 232 | [(query-exp cond-exp) (apply values (take-right expr 2))]) 233 | `(,query-name ,temps ,@control-args (lambda ,temp-args (lambda () (begin ,@defs (pair ,cond-exp (lambda () ,query-exp))))) ))) 234 | 235 | (define (psmc-query? expr) 236 | (tempered-query? 'psmc-query expr)) 237 | (define (desugar-psmc-query expr) 238 | (desugar-tempered-query 'psmc-query expr)) 239 | 240 | (define (mh-query/annealed-init? expr) 241 | (tempered-query? 'mh-query/annealed-init expr)) 242 | (define (desugar-mh-query/annealed-init expr) 243 | (desugar-tempered-query 'mh-query/annealed-init expr)) 244 | 245 | ;;lazify adds delay to an expression. make sure that the expression is fully-desugarred first! 246 | (define (lazify? expr) (tagged-list? expr 'lazify)) 247 | (define (desugar-lazify expr) (make-lazy (de-sugar-all (second expr)))) 248 | (define (make-lazy sexpr) 249 | (cond 250 | ((or (begin? sexpr) (mem? sexpr)) (map make-lazy sexpr)) 251 | ((quoted? sexpr) sexpr) 252 | ((letrec? sexpr) `(letrec ,(map (lambda (binding) (list (first binding) (delay-expr (second binding)))) 253 | (second sexpr)) 254 | ,(make-lazy (third sexpr)))) 255 | ((lambda? sexpr) `(lambda ,(lambda-parameters sexpr) ,(make-lazy (lambda-body sexpr)))) ;;delay body? 256 | ((if? sexpr) `(if ,(make-lazy (second sexpr)) ,(delay-expr (third sexpr)) ,(delay-expr (fourth sexpr)))) 257 | ((application? sexpr) `(,(make-lazy (first sexpr)) ,@(map delay-expr (rest sexpr)))) 258 | (else sexpr) )) 259 | (define (delay-expr sexpr) 260 | (if (or (lambda? sexpr) (and (mem? sexpr) (lambda? (first sexpr)))) 261 | (make-lazy sexpr) 262 | `(pair 'delayed (mem (lambda () ,(make-lazy sexpr)))))) 263 | 264 | (define (delay? expr) (tagged-list? expr 'delay)) 265 | (define (desugar-delay expr) `(pair 'delayed (mem (lambda () ,(de-sugar-all (second expr)))))) 266 | 267 | (define (fragment-lambda? expr) (tagged-list? expr 'f-lambda)) 268 | (define (desugar-fragment-lambda sexpr) 269 | `(DPmem 1.0 (lambda ,(lambda-parameters sexpr) (if (flip) ,(lambda-body sexpr) (list 'delayed (lambda () ,(lambda-body sexpr))))))) 270 | 271 | (define (keyword? expr) (or (tagged-list? expr 'or) 272 | (tagged-list? expr 'and) 273 | (tagged-list? expr 'apply) 274 | (tagged-list? expr 'abort!))) 275 | 276 | (define (desugar-or sexpr) 277 | (if (= (length sexpr) 2) 278 | (second sexpr) 279 | `(if ,(second sexpr) 280 | #t 281 | ,(desugar-or `(or ,@(cddr sexpr)))))) 282 | 283 | (define (desugar-and sexpr) 284 | (if (= (length sexpr) 2) 285 | (second sexpr) 286 | `(if ,(second sexpr) 287 | ,(desugar-and `(and ,@(cddr sexpr))) 288 | #f))) 289 | 290 | (define (desugar-abort expr) 291 | `(tag 'abort abort)) 292 | 293 | (define (desugar-keyword expr) 294 | (cond ((eq? (car expr) 'or) (desugar-or expr)) 295 | ((eq? (car expr) 'and) (desugar-and expr)) 296 | ((eq? (car expr) 'abort!) (desugar-abort expr)) 297 | ((eq? (car expr) 'apply) 298 | `(cosh-apply ,@(cdr expr))))) 299 | 300 | 301 | 302 | (register-sugar! fragment-lambda? desugar-fragment-lambda) 303 | (register-sugar! lazify? desugar-lazify) 304 | ;;(register-sugar! fragmentize? desugar-fragmentize) 305 | 306 | 307 | ;; @form (let ((var val) ...) expr ...) 308 | ;; @desc 309 | ;; Let binds variables in the scope of the body of the let. 310 | ;; @param assignments An expression '((var val) ...) 311 | ;; @param exprs Body expressions that are evaluated within the environment where variables are assigned. 312 | ;; @return the result of evaluating the last body expr 313 | (register-sugar! let? let->lambda) 314 | 315 | ;; @form (let* ((var val) ...) expr ...) 316 | ;; @desc 317 | ;; Let* binds variables in the scope of the body of the let. 318 | ;; Each assignment has access to the variables bound earlier on in the same let*. 319 | ;; @param assignments An expression '((var val) ...) 320 | ;; @param exprs Body expressions that are evaluated within the environment where variables are assigned. 321 | ;; @return the result of evaluating the last body expr 322 | (register-sugar! let*? desugar-let*) 323 | 324 | (register-sugar! lambda? (lambda (expr) `(lambda ,(lambda-parameters expr) ,(begin-wrap (cddr expr)))) 1) 325 | 326 | (register-sugar! named-let? named-let->letrec) 327 | (register-sugar! case? desugar-case) 328 | (register-sugar! cond? desugar-cond) 329 | (register-sugar! begin-defines? desugar-begin-defines) 330 | (register-sugar! define-fn? desugar-define-fn) 331 | (register-sugar! seq-with-load? expand-loads) 332 | (register-sugar! when? desugar-when) 333 | (register-sugar! keyword? desugar-keyword) 334 | 335 | ;;syntacic sugar query forms: 336 | (register-query-sugar 'mh-query) 337 | (register-query-sugar 'rejection-query) 338 | (register-query-sugar 'exact-query) 339 | (register-query-sugar 'query) 340 | (register-query-sugar 'enumeration-query) 341 | ;;(register-query-sugar 'primitive-laplace-mh-query 'laplace-mh-query) 342 | ;;(register-query-sugar 'primitive-gradient-query 'gradient-query) 343 | 344 | (register-sugar! psmc-query? desugar-psmc-query 1) 345 | (register-sugar! mh-query/annealed-init? desugar-mh-query/annealed-init 1) 346 | 347 | (register-sugar! delay? desugar-delay) 348 | 349 | ) 350 | -------------------------------------------------------------------------------- /cosh/dot.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh dot) 6 | 7 | (export polygraph->dot 8 | polygraph->file) 9 | 10 | (import (rnrs) 11 | (cosh polycommon) 12 | (scheme-tools) 13 | (scheme-tools object-id) 14 | (scheme-tools srfi-compat :1) 15 | (scheme-tools graph)) 16 | 17 | (define generate-graph-id 18 | (let ([counter (get-counter)]) 19 | (lambda () 20 | (number->string (+ (counter) 10000))))) 21 | 22 | (define (node->name graph node) 23 | (if (graph:leaf? graph node) 24 | (->string node) 25 | (node->graph-id graph node))) 26 | 27 | (define (node->graph-id graph node) 28 | (number->string (object->id node))) 29 | 30 | (define (node->dot graph node) 31 | (string-append (node->graph-id graph node) 32 | " [" 33 | "label=\"" (node->name graph node) "\"" 34 | "]\n")) 35 | 36 | (define (readable-number n) 37 | (->string:n n 5)) 38 | 39 | ;; If the target is a leaf node, don't link directly to it but 40 | ;; introduce a new node in the graph in order to make the resulting 41 | ;; graph easier to parse visually. 42 | (define (link->dot graph node link) 43 | (let* ([target-is-leaf (graph:leaf? graph (link->target link))] 44 | [target-graph-id (if target-is-leaf 45 | (generate-graph-id) 46 | (node->graph-id graph (link->target link)))]) 47 | (string-append 48 | (if target-is-leaf 49 | (string-append target-graph-id 50 | " [" 51 | "label=\"" (node->name graph (link->target link)) "\"" 52 | "]\n") 53 | "") 54 | (let* ([weight (link->weight link)]) 55 | (string-append (node->graph-id graph node) 56 | " -> " 57 | target-graph-id 58 | " [" 59 | "label=\"" 60 | (if (score-ref? weight) 61 | (string-append (node->name graph (score-ref->root weight)) ":" 62 | (node->name graph (score-ref->terminal-node weight))) 63 | (readable-number weight)) 64 | "\"" 65 | "]\n"))))) 66 | 67 | (define (entry->dot graph entry) 68 | (let ([node (first entry)] 69 | [links (rest entry)]) 70 | (apply string-append 71 | (pair (node->dot graph node) 72 | (map (lambda (link) (link->dot graph node link)) 73 | links))))) 74 | 75 | (define (polygraph->dot graph) 76 | (apply string-append 77 | `("digraph G {\n" 78 | ,@(map (lambda (entry) (entry->dot graph entry)) 79 | (graph->alist graph)) 80 | "\n}\n\n"))) 81 | 82 | (define (polygraph->file graph) 83 | (pe "Writing graph to /tmp/graph.dot\n") 84 | (system "rm /tmp/graph.dot") 85 | (with-output-to-file "/tmp/graph.dot" 86 | (lambda () (display (polygraph->dot graph)))) 87 | graph) 88 | 89 | ) -------------------------------------------------------------------------------- /cosh/global.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh global) 6 | 7 | (export merge-continuations 8 | verbose 9 | verbose-pe) 10 | 11 | (import (rnrs) 12 | (scheme-tools)) 13 | 14 | (define merge-continuations (make-parameter #f)) 15 | 16 | (define verbose (make-parameter #f)) 17 | 18 | (define (verbose-pe . args) 19 | (when (verbose) 20 | (apply pe args))) 21 | 22 | ) -------------------------------------------------------------------------------- /cosh/graph.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; Given cps-cc-thunk, create context graph. 4 | 5 | (library 6 | 7 | (cosh graph) 8 | 9 | (export cc-cps-thunk->graph 10 | node->graph 11 | init 12 | add-root 13 | step 14 | explode) 15 | 16 | (import (rnrs) 17 | (cosh continuation) 18 | (scheme-tools) 19 | (scheme-tools hash) 20 | (scheme-tools graph) 21 | (scheme-tools queue)) 22 | 23 | (define (node->graph node) 24 | (let ([graph (make-graph)]) 25 | (graph:add-node! graph node) 26 | (graph:set-root! graph node) 27 | graph)) 28 | 29 | (define (init thunk) 30 | (node->graph (thunk))) 31 | 32 | (define (add-root graph) 33 | (let ([new-root-cont (make-continuation 'root '(init) '(0.0))] 34 | [old-root-cont (graph:root graph)]) 35 | (graph:add-node! graph new-root-cont) 36 | (graph:link! graph new-root-cont old-root-cont 'init 0.0) 37 | (graph:set-root! graph new-root-cont) 38 | graph)) 39 | 40 | (define (step graph queue) 41 | (let ([node (dequeue! queue)]) 42 | (when (continuation? node) 43 | (let* ([values (continuation:support node)] 44 | [scores (continuation:scores node)] 45 | [nodes (map (lambda (v) (call-continuation node v)) 46 | values)]) 47 | (for-each (lambda (n v s) 48 | (if (graph:node-exists? graph n) 49 | (graph:link! graph node n v s) 50 | (begin 51 | (graph:add-child! graph node n v s) 52 | (enqueue! queue n)))) 53 | nodes values scores))) 54 | graph)) 55 | 56 | (define (explode graph graph-size-limit) 57 | (let ([queue (make-queue (graph:root graph))]) 58 | (let loop ([graph graph]) 59 | (if (or (and graph-size-limit 60 | (> (graph-size graph) graph-size-limit)) 61 | (queue-empty? queue)) 62 | graph 63 | (loop (step graph queue)))))) 64 | 65 | (define (cc-cps-thunk->graph thunk graph-size-limit) 66 | (add-root (explode (init thunk) graph-size-limit))) 67 | 68 | ) -------------------------------------------------------------------------------- /cosh/header.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh header) 6 | 7 | (export header) 8 | 9 | (import (rnrs)) 10 | 11 | (define header 12 | '((import (rnrs) 13 | (rnrs mutable-pairs) 14 | (scheme-tools object-id) 15 | (only (scheme-tools) 16 | pair rest sum pretty-print pe sym+num exact->inexact inexact->exact all-combinations) 17 | (only (scheme-tools math) random-real random-integer randomize-rng) 18 | (except (scheme-tools srfi-compat :1) any) 19 | (scheme-tools hash) 20 | (only (scheme-tools external) void) 21 | (only (cosh polycommon) make-root-node make-score-ref) 22 | (cosh continuation) 23 | (cosh application) 24 | (cosh abort) 25 | (cosh)) 26 | 27 | (define (thunk->node thunk) 28 | (make-root-node (sym+num 'app (object->id (list thunk '()))))) 29 | 30 | (define (symbolic-prob thunk v) 31 | (make-score-ref (thunk->node thunk) v)) 32 | 33 | (define (symbolic-log1minus expr) ;; TODO: improve 34 | `(log (- 1.0 (exp ,expr)))) 35 | 36 | (define (symbolic-kl A B domain) 37 | `(+ ,@(map (lambda (v) `(if (or (= ,(symbolic-prob A v) -inf.0) 38 | (= ,(symbolic-prob B v) -inf.0)) 39 | 0.0 40 | (* (exp ,(symbolic-prob A v)) 41 | (- ,(symbolic-prob A v) ,(symbolic-prob B v))))) 42 | domain))) 43 | 44 | (define kl-flip/no-apply 45 | (vector 46 | (lambda (self k A B domain) 47 | (make-continuation k 48 | (list #t #f) 49 | (list `(- ,(symbolic-kl A B domain)) 50 | (symbolic-log1minus `(- ,(symbolic-kl A B domain)))))) 51 | 'kl-flip)) 52 | 53 | (define flip 54 | (vector 55 | (lambda (self k . p) 56 | (make-continuation k 57 | (list #t #f) 58 | (if (not (null? p)) 59 | (list (log (first p)) (log (- 1.0 (first p)))) 60 | (list (log .5) (log .5))))) 61 | 'flip)) 62 | 63 | (define log-flip 64 | (vector 65 | (lambda (self k . p) 66 | (make-continuation k 67 | (list #t #f) 68 | (if (not (null? p)) 69 | (list (first p) (log (- 1.0 (exp (first p))))) 70 | (list (log .5) (log .5))))) 71 | 'log-flip)) 72 | 73 | (define sample-integer 74 | (vector 75 | (lambda (self k n) 76 | (make-continuation k 77 | (iota n) 78 | (make-list n (- (log n))))) 79 | 'sample-integer)) 80 | 81 | (define sample-discrete 82 | (vector 83 | (lambda (self k probs) 84 | (make-continuation k 85 | (iota (length probs)) 86 | (map log probs))) 87 | 'sample-discrete)) 88 | 89 | 90 | (define top 91 | (vector 92 | (lambda (self top-value) 93 | (begin 94 | (display "result: ") 95 | (pretty-print top-value) 96 | top-value)) 97 | 'top)) 98 | 99 | (define cosh-apply 100 | (vector 101 | (lambda (self k proc list-of-args) 102 | (apply (vector-ref proc 0) (append (list proc k) list-of-args))) 103 | 'apply)) 104 | 105 | (randomize-rng))) 106 | 107 | ) 108 | -------------------------------------------------------------------------------- /cosh/marg.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; Given graph, compute marginal probabilities. 4 | 5 | (library 6 | 7 | (cosh marg) 8 | 9 | (export marg-graph) 10 | 11 | (import (rnrs) 12 | (rnrs mutable-pairs) 13 | (cosh continuation) 14 | (scheme-tools) 15 | (scheme-tools graph) 16 | (scheme-tools queue) 17 | (scheme-tools mem) 18 | (scheme-tools hash) 19 | (scheme-tools object-id) 20 | (scheme-tools math iterate)) 21 | 22 | (define (node->variable-name node) 23 | (sym+num 'n 24 | (if (continuation? node) 25 | (continuation:id node) 26 | (object->id node)))) 27 | 28 | (define (variable-name->node name) 29 | (id->object (sym+num->num name))) 30 | 31 | (define (marg-graph graph) 32 | (let-values ([(leaves eqn) (graph->eqns graph)]) 33 | (let ([marginal-values (iterate/eqns eqn 0.0)]) 34 | (let ([nodename->prior (alist->hash-table marginal-values finitize-equal? finitize-hash)]) 35 | (map (lambda (leaf-name) (pair (variable-name->node leaf-name) 36 | (hash-table-ref/default nodename->prior leaf-name 'unknown))) 37 | leaves))))) 38 | 39 | ;; TODO: convert to log probabilities 40 | (define (graph->eqns graph) 41 | (define leaves '()) 42 | (values 43 | leaves 44 | (map (lambda (node) 45 | (when (graph:leaf? graph node) 46 | (set! leaves (cons (node->variable-name node) leaves))) 47 | `(= ,(node->variable-name node) 48 | ,(if (equal? node (graph:root graph)) 49 | 1.0 50 | (let ([links (graph:parent-links graph node)]) 51 | (if (null? links) 52 | (error node "no parent-links found!") 53 | `(+ ,@(map (lambda (link) `(* ,(link->weight link) 54 | ,(node->variable-name (link->target link)))) 55 | links))))))) 56 | (map car (graph->alist graph))))) 57 | 58 | ) -------------------------------------------------------------------------------- /cosh/polycommon.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; Utilities used by the polynomial graph-building and 4 | ;; equation-generating part of cosh. 5 | 6 | (library 7 | 8 | (cosh polycommon) 9 | 10 | (export graph:reachable-terminals 11 | graph:notify-ancestors-of-connection! 12 | node:id 13 | score-ref->terminal-node 14 | score-ref->root 15 | score-ref? 16 | make-score-ref 17 | link-promise->label 18 | link-promise->weight 19 | make-link-promise 20 | terminal-value? 21 | value? 22 | make-root-node 23 | identity-cont-closure) 24 | 25 | (import (rnrs) 26 | (cosh continuation) 27 | (cosh application) 28 | (scheme-tools) 29 | (scheme-tools object-id) 30 | (scheme-tools hash) 31 | (scheme-tools mem) 32 | (scheme-tools watcher) 33 | (scheme-tools graph) 34 | (scheme-tools graph callback) 35 | (scheme-tools graph utils) 36 | (scheme-tools srfi-compat :1)) 37 | 38 | (define (make-root-node id) 39 | (make-continuation id '(init) '(0.0))) 40 | 41 | (define identity-cont-closure 42 | (vector (lambda (self top-value) top-value) 43 | 'top)) 44 | 45 | (define (node:id node) 46 | (cond [(continuation? node) (continuation:id node)] 47 | [(application? node) (application:id node)] 48 | [else (object->id node)])) 49 | 50 | (define (value? obj) 51 | (and (not (continuation? obj)) 52 | (not (application? obj)))) 53 | 54 | (define (terminal-value? graph node) 55 | (and (value? node) 56 | (graph:leaf? graph node))) 57 | 58 | (define (graph:reachable-terminals graph node) 59 | (traverse node 60 | (lambda (node) (graph:children graph node)) 61 | (lambda (node list-of-terminals) 62 | (if (terminal-value? graph node) 63 | (cons node list-of-terminals) 64 | (apply append list-of-terminals))) 65 | (make-watcher) 66 | '())) 67 | 68 | (define (graph:terminals&callbacks graph node last-node) 69 | (let ([terminals (graph:reachable-terminals graph node)] 70 | [callbacks (graph:ancestor-callbacks graph last-node)]) 71 | (values terminals callbacks))) 72 | 73 | (define (graph:notify-ancestors-of-connection! graph node last-node) 74 | (let-values ([(terminals callbacks) (graph:terminals&callbacks graph node last-node)]) 75 | (map (lambda (callback) (map (lambda (terminal) (callback terminal)) terminals)) 76 | callbacks))) 77 | 78 | (define (make-score-ref root-node terminal-node) 79 | (list 'score-ref root-node terminal-node)) 80 | 81 | (define (score-ref? obj) 82 | (tagged-list? obj 'score-ref)) 83 | 84 | (define score-ref->root second) 85 | 86 | (define score-ref->terminal-node third) 87 | 88 | (define (make-link-promise weight label) 89 | (list 'link-promise weight label)) 90 | 91 | (define link-promise->weight second) 92 | 93 | (define link-promise->label third) 94 | 95 | ) -------------------------------------------------------------------------------- /cosh/polygraph.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh polygraph) 6 | 7 | (export return-thunk->polygraph) 8 | 9 | (import (rnrs) 10 | (cosh polycommon) 11 | (cosh continuation) 12 | (cosh abort) 13 | (cosh application) 14 | (scheme-tools) 15 | (scheme-tools object-id) 16 | (scheme-tools hash) 17 | (scheme-tools mem) 18 | (scheme-tools watcher) 19 | (scheme-tools graph) 20 | (scheme-tools graph callback) 21 | (scheme-tools graph utils) 22 | (scheme-tools srfi-compat :1)) 23 | 24 | ;; Make graph, create a root node in graph, new callback registry, 25 | ;; then call build-graph. 26 | (define (return-thunk->polygraph thunk graph-size-limit) 27 | (let ([graph (make-graph)] 28 | [root-node (make-root-node 'root)] 29 | [root-link-promise (make-link-promise 0.0 #t)]) 30 | (graph:add-node! graph root-node) 31 | (graph:set-root! graph root-node) 32 | (build-graph graph graph-size-limit thunk root-node root-link-promise) 33 | graph)) 34 | 35 | ;; Create/retrieve graph node for new (thunk) result, connect to last 36 | ;; node in graph. Dispatch according to type of node. 37 | (define (build-graph graph graph-size-limit thunk last-node link-promise) 38 | (define (get-handler node) 39 | (cond [(continuation? node) build-graph:continuation] 40 | [(application? node) build-graph:application] 41 | [else build-graph:value])) 42 | (when 43 | (or (not graph-size-limit) 44 | (<= (graph-size graph) graph-size-limit)) ;; FIXME: graph-size slow? 45 | (let ([node (thunk)]) 46 | (when (not (abort? node)) 47 | (let* ([handler (get-handler node)] 48 | [is-new (graph:add/link! graph last-node node 49 | (link-promise->label link-promise) 50 | (link-promise->weight link-promise))]) 51 | (if is-new 52 | (handler graph graph-size-limit node last-node) 53 | (graph:notify-ancestors-of-connection! graph node last-node))))))) 54 | 55 | ;; Notify the callbacks of all ancestors that we found a terminal. 56 | (define (build-graph:value graph graph-size-limit node last-node) 57 | (graph:notify-ancestors-of-connection! graph node last-node)) 58 | 59 | ;; Extend graph by exploring all possible branches of the (xrp) 60 | ;; continuation. 61 | (define (build-graph:continuation graph graph-size-limit node last-node) 62 | (for-each (lambda (value score) 63 | (build-graph graph 64 | graph-size-limit 65 | (lambda () (call-continuation node value)) 66 | node 67 | (make-link-promise score value))) 68 | (continuation:support node) 69 | (continuation:scores node))) 70 | 71 | ;; Make thunk for delimited application, root node for application 72 | ;; subgraph, callback to continue with outer continuation when 73 | ;; terminal values are found; associate callback with application 74 | ;; subgraph root. If the delimited application root node is new, 75 | ;; build graph from there. If not, just call callback on all existing 76 | ;; terminal values. 77 | (define (build-graph:application graph graph-size-limit node last-node) 78 | (let* ([subthunk (lambda () (call-application-with-cont node identity-cont-closure))] 79 | [subroot-node (make-root-node (sym+num 'app (application:delimited-id node)))] 80 | [subroot-link-promise (make-link-promise 0.0 #t)] 81 | [subroot-is-new (graph:add/retrieve! graph subroot-node)] 82 | [callback (recursive-mem 83 | (lambda (value) 84 | (build-graph graph 85 | graph-size-limit 86 | (lambda () (call-application-cont node value)) 87 | node 88 | (make-link-promise (make-score-ref subroot-node value) 89 | value))) 90 | (lambda () #f))]) 91 | (graph:register-callback! graph subroot-node callback) 92 | (if subroot-is-new 93 | (build-graph graph graph-size-limit subthunk subroot-node subroot-link-promise) 94 | (map callback (graph:reachable-terminals graph subroot-node))))) 95 | 96 | ) -------------------------------------------------------------------------------- /cosh/polymap.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; A polymap is a summary graph of the dependency structure of a 4 | ;; polygraph. Contains a node for each subproblem (root 5 | ;; node). Whenever a subproblem A references another subproblem B, 6 | ;; there is a link from A to B in the polymap. In general, this graph 7 | ;; is not acyclic. 8 | 9 | (library 10 | 11 | (cosh polymap) 12 | 13 | (export polygraph->polymap) 14 | 15 | (import (rnrs) 16 | (scheme-tools) 17 | (scheme-tools graph) 18 | (scheme-tools watcher) 19 | (cosh polycommon)) 20 | 21 | (define (polygraph->polymap graph) 22 | (let ([polymap (make-graph)] 23 | [seen? (make-watcher)]) 24 | (build-polymap! graph seen? polymap (graph:root graph) (graph:root graph)))) 25 | 26 | (define (add-score-ref-links! graph seen? polymap root weight) 27 | (let add-links! ([weight weight]) 28 | (cond [(score-ref? weight) 29 | (let ([subroot (score-ref->root weight)]) 30 | (build-polymap! graph seen? polymap subroot subroot) 31 | (graph:link! polymap root subroot subroot 'unweighted))] 32 | [(list? weight) (map add-links! weight)] 33 | [else #f]))) 34 | 35 | (define (build-polymap! graph seen? polymap root node) 36 | (when (not (seen? (pair node root))) 37 | (when (null? (graph:parent-links graph node)) 38 | (graph:add-node! polymap node)) 39 | (for-each (lambda (link) 40 | (let ([weight (link->weight link)]) 41 | (add-score-ref-links! graph seen? polymap root weight) 42 | (build-polymap! graph seen? polymap root (link->target link)))) 43 | (graph:child-links graph node))) 44 | polymap) 45 | 46 | ) -------------------------------------------------------------------------------- /cosh/polymarg.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; Given polygraph, compute marginal probabilities by generating a 4 | ;; system of polynomial equations and calling an equation solver. 5 | 6 | (library 7 | 8 | (cosh polymarg) 9 | 10 | (export polymarg-graph 11 | subgraph->equations 12 | lookup-leaf-values) 13 | 14 | (import (rnrs) 15 | (cosh polycommon) 16 | (scheme-tools) 17 | (scheme-tools object-id) 18 | (scheme-tools watcher) 19 | (scheme-tools graph) 20 | (scheme-tools graph utils) 21 | (scheme-tools math iterate) 22 | (scheme-tools srfi-compat :1) 23 | (scheme-tools srfi-compat :13) 24 | (scheme-tools hash)) 25 | 26 | (define (polygraph->equations graph) 27 | (union 28 | (map (lambda (root) (subgraph->equations graph root)) 29 | (graph:root-nodes graph)) 30 | finitize-equal?)) 31 | 32 | ;; go through subgraph top to bottom 33 | ;; make a hash table that stores for each node what the incoming links are 34 | ;; convert table to equations 35 | (define (subgraph->equations graph root) 36 | (let ([seen? (make-watcher)] 37 | [equation-table (make-finitize-hash-table)]) 38 | (let nodes->equation-table ([nodes (list root)]) 39 | (when (not (null? nodes)) 40 | (let ([node (first nodes)]) 41 | (if (not (seen? node)) 42 | (let ([child-links (graph:child-links graph node)]) 43 | (for-each (lambda (child-link) 44 | (hash-table-set! equation-table 45 | (link->target child-link) 46 | (pair (make-link (link->label child-link) 47 | (link->weight child-link) 48 | node) 49 | (hash-table-ref/default equation-table 50 | (link->target child-link) 51 | '())))) 52 | child-links) 53 | (nodes->equation-table (append (map link->target child-links) 54 | (rest nodes)))) 55 | (nodes->equation-table (rest nodes)))))) 56 | (hash-table-fold equation-table 57 | (lambda (node links eqns) 58 | (pair (node->eqn root node links) eqns)) 59 | (list (node->eqn root root '()))))) 60 | 61 | (define (node->variable-name root node) 62 | (sym-append 'g (node:id root) 'n (node:id node))) 63 | 64 | (define (variable-name->node name) 65 | (let ([s (symbol->string name)]) 66 | (id->object (string->number (string-drop s (+ (string-index s #\n) 1)))))) 67 | 68 | (define (link->variable/weight link) 69 | (let ([weight (link->weight link)]) 70 | (let score-refs->vars ([weight weight]) 71 | (cond [(score-ref? weight) 72 | (node->variable-name (score-ref->root weight) 73 | (score-ref->terminal-node weight))] 74 | [(list? weight) (map score-refs->vars weight)] 75 | [(number? weight) weight] 76 | [(symbol? weight) weight] 77 | [else (error weight "unknown link weight type")])))) 78 | 79 | (define (node->eqn root node parent-links) 80 | `(= ,(node->variable-name root node) 81 | ,(if (null? parent-links) 82 | 0.0 83 | `(logsumexp ,@(map (lambda (link) 84 | `(+ ,(link->variable/weight link) 85 | ,(node->variable-name root (link->target link)))) 86 | parent-links))))) 87 | 88 | (define (lookup-leaf-values graph solutions) 89 | (let ([leaves (graph:reachable-terminals graph (graph:root graph))]) 90 | (map (lambda (node) 91 | (let ([var-name (node->variable-name (graph:root graph) node)]) 92 | (pair node (hash-table-ref solutions var-name)))) 93 | leaves))) 94 | 95 | ;; FIXME: convert to return hash table 96 | (define (polymarg-graph graph) 97 | (let* ([equations (polygraph->equations graph)] 98 | [solutions (iterate/eqns equations 0.0)]) 99 | (lookup-leaf-values graph solutions))) 100 | 101 | ) 102 | -------------------------------------------------------------------------------- /cosh/preamble.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh preamble) 6 | 7 | (export preamble 8 | with-preamble) 9 | 10 | (import (rnrs)) 11 | 12 | (define (with-preamble expr) 13 | `(begin 14 | ,@preamble 15 | (begin 16 | ,@expr))) 17 | 18 | (define preamble 19 | '((define sample (lambda (thunk) (thunk))) 20 | 21 | (define true #t) 22 | 23 | (define false #f) 24 | 25 | (define all 26 | (lambda (lst) 27 | (if (null? lst) 28 | #t 29 | (if (first lst) 30 | (all (rest lst)) 31 | #f)))) 32 | 33 | (define any 34 | (lambda (lst) 35 | (if (null? lst) 36 | #f 37 | (if (first lst) 38 | #t 39 | (any (rest lst)))))) 40 | 41 | (define rejection-query 42 | (lambda (nfqp) 43 | (let ((val (nfqp))) 44 | (if (first val) 45 | ((rest val)) 46 | (rejection-query nfqp))))) 47 | 48 | (define exact-query 49 | (lambda (nfqp) (rejection-query nfqp))) 50 | 51 | (define repeat 52 | (lambda (N proc) 53 | (if (= N 0) '() (pair (proc) (repeat (- N 1) proc))))) 54 | 55 | (define (mem proc) 56 | (let ([mt '()]) 57 | (lambda args 58 | (let ([entry (assoc args mt)]) 59 | (if entry 60 | (cdr entry) 61 | (let ([val (cosh-apply proc args)]) 62 | (set! mt (cons (cons args val) mt)) 63 | val)))))) 64 | 65 | (define (force obj) 66 | (if (pair? obj) 67 | (if (eq? (first obj) 'delayed) 68 | (force ((rest obj))) 69 | obj) 70 | obj)) 71 | 72 | (define uniform-draw 73 | (lambda (lst) 74 | (if (null? lst) 75 | '() 76 | (list-ref lst (sample-integer (length lst)))))) 77 | 78 | (define (%sum-repeat proc n s) 79 | (if (= n 0) 80 | s 81 | (%sum-repeat proc 82 | (- n 1) 83 | (+ s (proc))))) 84 | 85 | (define (sum-repeat proc n) 86 | (%sum-repeat proc n 0)) 87 | 88 | (define (nflip p) 89 | (if (flip p) 1 0)) 90 | 91 | (define (kl-flip A B domain) 92 | (let* ([_ (A)] 93 | [_ (B)]) 94 | (kl-flip/no-apply A B domain))) 95 | 96 | (define (binomial p n) 97 | (sum-repeat (lambda () (nflip p)) 98 | n)) 99 | 100 | (define (multinomial vals probs) 101 | (list-ref vals (sample-discrete probs))) 102 | 103 | (define (map proc . lsts) 104 | (if (null? (rest lsts)) (single-map proc (first lsts)) (multi-map proc lsts))) 105 | 106 | (define (single-map proc lst) 107 | (if (null? lst) 108 | '() 109 | (pair (proc (first lst)) 110 | (map proc (rest lst))))) 111 | 112 | (define (multi-map proc lsts) ;;takes list of lists and proc of that many arguments. 113 | (if (null? (first lsts)) 114 | '() 115 | (pair (apply proc (single-map first lsts)) 116 | (multi-map proc (single-map rest lsts))))) 117 | 118 | (define (many-map proc . lsts) (multi-map proc lsts)) 119 | 120 | (define (filter proc lst) 121 | (if (null? lst) 122 | '() 123 | (let ([fst (first lst)] 124 | [filtered-rst (filter proc (rest lst))]) 125 | (if (proc fst) 126 | (pair fst filtered-rst) 127 | filtered-rst)))) 128 | 129 | (define (foldl f z xs) 130 | (if (null? xs) 131 | z 132 | (foldl f (f z (first xs)) (rest xs)))) 133 | 134 | (define (compose f g) 135 | (lambda args (f (apply g args)))) 136 | 137 | (define (no-proposals x) 138 | x) 139 | 140 | )) 141 | 142 | ) -------------------------------------------------------------------------------- /cosh/visualize.ss: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library 4 | 5 | (cosh visualize) 6 | 7 | (export visualize-graph 8 | visualize-sampling) 9 | 10 | (import (rnrs) 11 | (only (scheme-tools math) sample-discrete) 12 | (only (scheme-tools srfi-compat :1) filter-map) 13 | (cosh continuation) 14 | (scheme-tools) 15 | (scheme-tools watcher) 16 | (scheme-tools graph utils) 17 | (scheme-tools graph) 18 | (scheme-tools object-id) 19 | (scheme-tools ubigraph)) 20 | 21 | (define history-contexts #f) 22 | 23 | (define vis-trace 20) 24 | 25 | (define hex-alphabet "0123456789abcdef") 26 | 27 | ;; (let ([id (vector-ref (continuation:closure node) 1)]) 28 | ;; (when print-ids 29 | ;; (pe id ": \n") 30 | ;; (pretty-print (id->object id)) 31 | ;; (pe "\n") 32 | ;; (number->string id)) 33 | ;; "")) 34 | (define (node-label node-id print-ids) 35 | "") 36 | 37 | (define (node->id node history) 38 | (if history-contexts 39 | (object->id history) 40 | (object->id node))) 41 | 42 | (define (readable-booleans obj) 43 | (cond [(pair? obj) (pair (readable-booleans (car obj)) 44 | (readable-booleans (cdr obj)))] 45 | [(eq? obj #t) 1] 46 | [(eq? obj #f) 0] 47 | [else obj])) 48 | 49 | (define (edge->id from to label weight) 50 | (object->id (list from to label weight))) 51 | 52 | (define (history->edge-id history label weight) 53 | (object->id (list history label weight))) 54 | 55 | (define (draw-internal node-id) 56 | (ubi-node node-id (node-label node-id #f)) 57 | (ubi-node-attrib node-id "shape" "cube")) 58 | 59 | (define (draw-leaf node-id node-lst) 60 | (if (null? node-lst) 61 | (ubi-node node-id (->string node-id)) 62 | (ubi-node node-id (->string (readable-booleans (car node-lst))))) 63 | (ubi-node-attrib node-id "shape" "sphere") 64 | (ubi-node-attrib node-id "color" "#00ff00") 65 | (ubi-node-attrib node-id "size" "2.0")) 66 | 67 | (define (draw-root node-id) 68 | (ubi-node node-id "") 69 | (ubi-node-attrib node-id "shape" "sphere") 70 | (ubi-node-attrib node-id "color" "#ff0000") 71 | (ubi-node-attrib node-id "size" "2.0")) 72 | 73 | (define (draw-node node-id node-type . maybe-node) 74 | (cond [(eq? node-type 'root) (draw-root node-id)] 75 | [(eq? node-type 'leaf) (draw-leaf node-id maybe-node)] 76 | [else (draw-internal node-id)])) 77 | 78 | (define (draw-edge edge-id from-id to-id label weight) 79 | (ubi-id-edge edge-id 80 | from-id 81 | to-id 82 | (string-append (->string (readable-booleans label)) " p=" (->string:n weight 4))) 83 | (ubi-id-edge-attrib edge-id 84 | "oriented" 85 | "true") 86 | (ubi-id-edge-attrib edge-id 87 | "fontcolor" 88 | "#aaaaaa") 89 | (ubi-id-edge-attrib edge-id 90 | "arrow" 91 | "true") 92 | (ubi-id-edge-attrib edge-id 93 | "width" 94 | "7")) 95 | 96 | (define (visualize graph node done? interactive) 97 | (map (lambda (link) 98 | (let* ([child (link->target link)] 99 | [child-type (node->type graph child)] 100 | [child-id (node->id child #f)] 101 | [edge-id (edge->id node child (link->label link) (link->weight link))]) 102 | (when interactive (read-char)) 103 | (draw-node child-id child-type child) 104 | (draw-edge edge-id 105 | (node->id node #f) 106 | (node->id child #f) 107 | (link->label link) 108 | (link->weight link)) 109 | (when (not (done? child)) 110 | (visualize graph child done? interactive)))) 111 | (graph:child-links graph node))) 112 | 113 | (define (visualize-graph graph interactive) 114 | (ubi-reset) 115 | (for-each 116 | (lambda (root) 117 | (draw-node (node->id root #f) 'root) 118 | (visualize graph 119 | root 120 | (make-watcher) 121 | interactive)) 122 | (graph:root-nodes graph))) 123 | 124 | (define (alist-add/replace el lst eql) 125 | (cons el 126 | (filter (lambda (kv) (not (eql (car kv) (car el)))) 127 | lst))) 128 | 129 | (define (alist-add/replace* els lst eql) 130 | (if (null? els) 131 | lst 132 | (alist-add/replace* (cdr els) 133 | (alist-add/replace (car els) 134 | lst 135 | eql) 136 | eql))) 137 | 138 | (define (multinomial-draw vals weights) 139 | (list-ref vals (sample-discrete weights))) 140 | 141 | (define (sample-link graph node) 142 | (let* ([links (graph:child-links graph node)] 143 | [scores (map link->weight links)]) 144 | (if (null? links) 145 | #f 146 | (multinomial-draw links scores)))) 147 | 148 | (define (dec->hex n) 149 | (let ([h1 (div n 16)] 150 | [h2 (mod n 16)]) 151 | (list->string (list (string-ref hex-alphabet h1) 152 | (string-ref hex-alphabet h2))))) 153 | 154 | (define (hex r g b sat) 155 | (apply string-append 156 | (cons "#" (map (lambda (x) (dec->hex (inexact->exact (div (max x (min sat 100)) 1)))) 157 | (list r g b))))) 158 | 159 | (define (make-root-node-salience-task node-id salience) 160 | (make-countdown-task 161 | (lambda (node-id salience) 162 | (ubi-node-attrib node-id 163 | "color" 164 | (hex 255 0 0 (* 255 (/ salience vis-trace))))) 165 | node-id 166 | salience)) 167 | 168 | (define (make-leaf-node-salience-task node-id salience) 169 | (make-countdown-task 170 | (lambda (node-id salience) 171 | (ubi-node-attrib node-id 172 | "color" 173 | (hex 0 255 0 (* 255 (/ salience vis-trace))))) 174 | node-id 175 | salience)) 176 | 177 | (define (make-internal-node-salience-task node-id salience) 178 | (make-countdown-task 179 | (lambda (node-id salience) 180 | (ubi-node-attrib node-id 181 | "color" 182 | (hex 30 30 255 (* 255 (/ salience vis-trace))))) 183 | node-id 184 | salience)) 185 | 186 | (define (make-link-salience-task link-id salience) 187 | (make-countdown-task 188 | (lambda (link-id salience) 189 | (ubi-id-edge-attrib link-id 190 | "color" 191 | (hex 0 0 255 (* 255 (/ salience vis-trace))))) 192 | link-id 193 | salience)) 194 | 195 | (define (make-countdown-task setter obj-id val) 196 | (pair obj-id 197 | (lambda () 198 | (if (= val 0) 199 | #f 200 | (begin 201 | (setter obj-id val) 202 | (make-countdown-task setter obj-id (- val 1))))))) 203 | 204 | (define (make-node-salience-task node-type node-id init-salience) 205 | (cond [(eq? node-type 'root) 206 | (make-root-node-salience-task node-id vis-trace)] 207 | [(eq? node-type 'leaf) 208 | (make-leaf-node-salience-task node-id vis-trace)] 209 | [else (make-internal-node-salience-task node-id vis-trace)])) 210 | 211 | ;; Call draw-node, draw-edge, tasks with node ids compute node ids 212 | ;; from both nodes and histories add flag that distinguishes between 213 | ;; the two. 214 | 215 | (define (node->type graph node) 216 | (cond [(graph:root? graph node) 'root] 217 | [(graph:leaf? graph node) 'leaf] 218 | [else 'internal])) 219 | 220 | (define (%visualize-sampling graph node wait background-tasks history) 221 | (let* ([filtered-tasks (filter-map (compose (lambda (f) (f)) cdr) 222 | background-tasks)] 223 | [link (sample-link graph node)]) 224 | (if (not link) 225 | (%visualize-sampling-start graph 226 | wait 227 | filtered-tasks) 228 | (let* ([new-history (cons (link->label link) history)] 229 | [child (link->target link)] 230 | [child-type (node->type graph child)] 231 | [child-id (node->id child new-history)] 232 | [link-id (if history-contexts 233 | (history->edge-id history (link->label link) (link->weight link)) 234 | (edge->id node child (link->label link) (link->weight link)))]) 235 | (draw-node child-id child-type child) 236 | (draw-edge link-id 237 | (node->id node history) 238 | child-id 239 | (link->label link) 240 | (link->weight link)) 241 | (ubi-node-attrib child-id "color" "#ffffff") 242 | (ubi-id-edge-attrib link-id "color" "#ffffff") 243 | (let* ([node-task (make-node-salience-task child-type child-id vis-trace)] 244 | [link-task (make-link-salience-task link-id vis-trace)] 245 | [new-tasks (alist-add/replace* (list node-task link-task) 246 | filtered-tasks 247 | equal?)]) 248 | (when (not (= wait 0.0)) 249 | (time-wait wait)) 250 | (%visualize-sampling graph child wait new-tasks new-history)))))) 251 | 252 | (define (%visualize-sampling-start graph wait background-tasks) 253 | (let* ([root-node (graph:root graph)] 254 | [root-id (node->id root-node '())]) 255 | (time-wait 1) 256 | (draw-node root-id 'root) 257 | (time-wait wait) 258 | (%visualize-sampling graph 259 | root-node 260 | wait 261 | (alist-add/replace 262 | (make-node-salience-task 'root root-id vis-trace) 263 | background-tasks 264 | equal?) 265 | '()))) 266 | 267 | (define (visualize-sampling graph wait) 268 | (ubi-reset) 269 | (%visualize-sampling-start graph wait '())) 270 | 271 | ) -------------------------------------------------------------------------------- /docs/concepts.md: -------------------------------------------------------------------------------- 1 | # Concepts 2 | 3 | * _thunk_ 4 | 5 | A procedure that takes no arguments. 6 | 7 | * _cc-cps-thunk_ 8 | 9 | A thunk in closure-converted continuation-passing style. Whenever such a procedure gets to a random choice, it returns the current continuation, which is in hashable form due to cc. 10 | 11 | * _return-thunk_ 12 | 13 | A cc-cps-thunk that has also undergone app conversion: All applications return to the top-level and pass function, continuation, and arguments back (all of which are hashable due to cc). 14 | 15 | * _graph_ 16 | 17 | An acyclic graph for a probabilistic program, with one node for each random choice (as identified by its continuation and support). Corresponds to a system of linear equations. 18 | 19 | * _polygraph_ 20 | 21 | A graph for a probabilistic program that makes subproblems explicit. For each subproblem, there is a parentless node, and references to the marginal probabilities of a subproblem are possible. Cyclic dependencies are only introduced via such references. Corresponds to a system of polynomial equations. 22 | 23 | * _polymap_ 24 | 25 | A summary graph of the dependency structure of a polygraph. Contains a node for each subproblem (root node). Whenever a subproblem A references another subproblem B, there is a link from A to B in the polymap. In general, this graph is not acyclic. 26 | 27 | * _components_ 28 | 29 | Clustering the strongly connected components of a polymap results in the acyclic components graph. Each component corresponds to a (linear or polynomial) problem that can be solved independently given the referenced parent parameters. By solving the components in topological order, the marginal distribution of the overall inference problem can be computed. 30 | -------------------------------------------------------------------------------- /tests/forcing-from-above.church: -------------------------------------------------------------------------------- 1 | (define (forcing-from-above z n) 2 | (rejection-query 3 | (define x (flip)) 4 | x 5 | (if (= n 0) 6 | #t 7 | (equal? (forcing-from-above x (- n 1)) 8 | z)))) 9 | 10 | (forcing-from-above #t 15) -------------------------------------------------------------------------------- /tests/marginalize.church: -------------------------------------------------------------------------------- 1 | (define foo 2 | (marginalize 3 | (lambda () (and (flip) (flip))))) 4 | 5 | (list (foo) 6 | (foo)) 7 | 8 | -------------------------------------------------------------------------------- /tests/pragmatics.church: -------------------------------------------------------------------------------- 1 | ;;scalar implicature exs 2 | 3 | ;;use partial knowledge form of belief formation. 4 | ;;for this to make sense the state must be the state of each object (rather than the total number true). 5 | ;;(define (belief actual-state access) (lambda () (map (lambda (ac st pr) (if ac st (pr))) access actual-state substate-priors))) 6 | (define (belief actual-state access) 7 | (map (lambda (ac st pr) (if ac st (sample pr))) 8 | access 9 | actual-state 10 | (substate-priors))) 11 | 12 | (define (baserate) 0.6) 13 | 14 | (define (substate-priors) 15 | (list (lambda () (flip (baserate))) 16 | (lambda () (flip (baserate))) 17 | (lambda () (flip (baserate))))) 18 | 19 | (define (state-prior) 20 | (map sample (substate-priors))) 21 | 22 | ;;use truth-functional meanings for sentences. 23 | (define (sentence-prior) 24 | (uniform-draw (list all-p some-p none-p))) 25 | 26 | (define (all-p state) (all state)) 27 | (define (some-p state) (any state)) 28 | (define (none-p state) (not (some-p state))) 29 | 30 | ;;what is the speaker likely to say, given their informational 31 | ;;access and an assumed state of the world? 32 | (define (speaker access state depth) 33 | (rejection-query 34 | (define s (sentence-prior)) 35 | s 36 | (equal? (belief state access) 37 | (listener access s depth)))) 38 | 39 | ;;what state of teh world will the listener infer, given what the 40 | ;;speaker said and the speaker's informational access? 41 | (define (listener speaker-access sentence depth) 42 | (rejection-query 43 | (define state (state-prior)) 44 | state 45 | (if (= 0 depth) 46 | (sentence state) ;;sentence is true of state. 47 | (equal? sentence ;;sentence is what speaker would have said given state and access. 48 | (speaker speaker-access state (- depth 1))) 49 | ))) 50 | 51 | (define (num-true state) 52 | (sum (map (lambda (x) (if x 1 0)) state))) 53 | 54 | (num-true (listener '(#t #t #t) some-p 7)) -------------------------------------------------------------------------------- /tests/simple-rejection.church: -------------------------------------------------------------------------------- 1 | (rejection-query 2 | (define x (flip)) 3 | (define y (flip)) 4 | (list x y) 5 | (or x y)) -------------------------------------------------------------------------------- /tests/stack-recursion.church: -------------------------------------------------------------------------------- 1 | (define (foo) 2 | (if (flip) 3 | (not (foo)) 4 | #t)) 5 | 6 | (foo) --------------------------------------------------------------------------------