├── .gitignore ├── AUTHORS ├── COPYING ├── COPYING.LESSER ├── COPYING.LISP ├── README.md ├── cl-bayesnet.asd ├── make-api-doc.sbcl ├── nets ├── ace.net ├── acesmall.net ├── alarm.dne ├── alarm.xml ├── asia.dne ├── chess1.dne ├── disconnected.dne ├── german1.dne ├── simple.dne └── test.dne ├── src ├── bn-utils.lisp ├── bn.lisp ├── clique-tree.lisp ├── compiler.lisp ├── emit-c.lisp ├── evidence.lisp ├── message.lisp ├── packages.lisp ├── parse-network.lisp ├── test.lisp ├── tries.lisp └── utils.lisp └── tests ├── emit-java.lisp ├── emit-lisp.lisp ├── java ├── BN.java └── BN.resource └── test-alarm.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | /cl-bayesnet.html 4 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Contributors 2 | ============ 3 | 4 | Lucas Hope 5 | -------------------------------------------------------------------------------- /COPYING.LESSER: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /COPYING.LISP: -------------------------------------------------------------------------------- 1 | The text of the LLGPL terms and conditions follows: 2 | 3 | Preamble to the Gnu Lesser General Public License 4 | 5 | Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 6 | 7 | The concept of the GNU Lesser General Public License version 3 8 | ("LGPL") has been adopted to govern the use and distribution of 9 | above-mentioned application. However, the LGPL uses terminology that 10 | is more appropriate for a program written in C than one written in 11 | Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if 12 | certain clarifications are made. This document details those 13 | clarifications. Accordingly, the license for the open-source Lisp 14 | applications consists of this document plus the LGPL. Wherever there 15 | is a conflict between this document and the LGPL, this document takes 16 | precedence over the LGPL. 17 | 18 | A "Library" in Lisp is a collection of Lisp functions, data and 19 | foreign modules. The form of the Library can be Lisp source code (for 20 | processing by an interpreter) or object code (usually the result of 21 | compilation of source code or built with some other 22 | mechanisms). Foreign modules are object code in a form that can be 23 | linked into a Lisp executable. When we speak of functions we do so in 24 | the most general way to include, in addition, methods and unnamed 25 | functions. Lisp "data" is also a general term that includes the data 26 | structures resulting from defining Lisp classes. A Lisp application 27 | may include the same set of Lisp objects as does a Library, but this 28 | does not mean that the application is necessarily a "work based on the 29 | Library" it contains. 30 | 31 | The Library consists of everything in the distribution file set before 32 | any modifications are made to the files. If any of the functions or 33 | classes in the Library are redefined in other files, then those 34 | redefinitions ARE considered a work based on the Library. If 35 | additional methods are added to generic functions in the Library, 36 | those additional methods are NOT considered a work based on the 37 | Library. If Library classes are subclassed, these subclasses are NOT 38 | considered a work based on the Library. If the Library is modified to 39 | explicitly call other functions that are neither part of Lisp itself 40 | nor an available add-on module to Lisp, then the functions called by 41 | the modified Library ARE considered a work based on the Library. The 42 | goal is to ensure that the Library will compile and run without 43 | getting undefined function errors. 44 | 45 | It is permitted to add proprietary source code to the Library, but it 46 | must be done in a way such that the Library will still run without 47 | that proprietary code present. Section 5 of the LGPL distinguishes 48 | between the case of a library being dynamically linked at runtime and 49 | one being statically linked at build time. Section 5 of the LGPL 50 | states that the former results in an executable that is a "work that 51 | uses the Library." Section 5 of the LGPL states that the latter 52 | results in one that is a "derivative of the Library", which is 53 | therefore covered by the LGPL. Since Lisp only offers one choice, 54 | which is to link the Library into an executable at build time, we 55 | declare that, for the purpose applying the LGPL to the Library, an 56 | executable that results from linking a "work that uses the Library" 57 | with the Library is considered a "work that uses the Library" and is 58 | therefore NOT covered by the LGPL. 59 | 60 | Because of this declaration, section 6 of LGPL is not applicable to 61 | the Library. However, in connection with each distribution of this 62 | executable, you must also deliver, in accordance with the terms and 63 | conditions of the LGPL, the source code of Library (or your derivative 64 | thereof) that is incorporated into this executable. 65 | 66 | End of Preamble 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-bayesnet - a Common Lisp Bayesian Network Inference Engine # 2 | 3 | ## Overview ## 4 | 5 | cl-bayesnet is a tool for the compilation and probability calculation of discrete, probabilistic [Bayesian Networks](http://en.wikipedia.org/wiki/Bayesian_network). 6 | 7 | It provides two types of compilation. The first is join-tree compilation. A join-tree is an auxiliary structure which uses message passing to calculate local probabilities given evidence in a network. Compiling a Bayesian Network to a join tree is quick, but message passing is relatively slow. The join tree's space cost should also be taken into account. 8 | 9 | The second type of compilation compiles the Bayesian Network into an Arithmetic Circuit, which is written as a series of arithmetic instructions. These instructions can be interpreted on the fly, or written out as source code for a compiler such as gcc. The compilation process is quite slow, but the instructions are evaluated much faster than message passing (using my implementation, anyway). My tests showed approximately 70x speed up of interpreted instructions over message passing, and then the C compiled instructions executed 20x faster than interpreted instructions! 10 | 11 | An additional advantage of the arithmetic circuit is that it compiles to a single, standalone function. That means it is perfect for embedded systems, and can be used anywhere, without dependence on any library at all! An absolutely minimal footprint. 12 | 13 | ## Scope and Goals ## 14 | 15 | The scope of cl-bayesnet is just Bayesian Network compilation and probability calculation. There is no API for building or modifying a Bayesian Network. There are no modelling tools. There is no GUI. These tools already exist, and have done for years. 16 | 17 | However, there are not many free, open-source Bayesian Network probability calculators. http://sourceforge.net/projects/bnj/ is the only other open-source one I know of. I know of no other project which can compile direct to machine code (through gcc) like cl-bayesnet can. 18 | 19 | The goals of this project is to be useful to developers who want to use the results of their Bayesian Network modelling freely in any domain. If there is demand, compilation to pure Java and compilation to pure Lisp can be quickly developed. 20 | 21 | ## Highlights ## 22 | 23 | - Load from dne, ace, xmlbif formats. 24 | - Simple query API. 25 | - Use message passing or arithmetic circuit methods. 26 | - Embeddable C code generation. Other languages such as Java and Lisp are possible. 27 | 28 | ## Using cl-bayesnet ## 29 | 30 | # Dependencies 31 | 32 | cl-bayesnet uses [S-XML](http://common-lisp.net/project/s-xml/) to parse xmlbif. It uses [trivial-shell](http://common-lisp.net/project/trivial-shell/) to call the C compiler and [CFFI](http://common-lisp.net/project/cffi/) to load the resultant shared object file. You can disable the dependencies on CFFI and trivial-shell by adding `:cl-bayesnet-no-cffi` to your Lisp's features list. 33 | 34 | All dependencies are available through [quicklisp](http://www.quicklisp.org). 35 | 36 | # Installation 37 | 38 | I suggest using [quicklisp](http://www.quicklisp.org). Install that, and then grab the source (via tarball or git) and put it in `~/quicklisp/local-projects/`. Symlinks work okay too. 39 | 40 | # Documentation 41 | 42 | See [the API-Documentation on github](https://github.com/lhope/cl-bayesnet/wiki/API-Documentation). It may not necessarily be up to date. 43 | 44 | Or, use `make-api-doc.sbcl` in this directory to make the API documentation (cl-bayesnet.html). This assumes you have [quicklisp](http://www.quicklisp.org) and [sbcl](http://www.sbcl.org) installed. 45 | 46 | # Usage 47 | 48 | See [tests/test-alarm.lisp](https://github.com/lhope/cl-bayesnet/blob/master/tests/test-alarm.lisp) for example usage. 49 | 50 | ## Ownership and License ## 51 | 52 | cl-bayesnet's contributors are listed in the `AUTHORS` file. The authors of cl-bayesnet grant you use of this software under the terms of the Lisp Lesser General Public License (LLGPL). For details see the files `COPYING`, `COPYING.LESSER` and `COPYING.LISP` in this directory. 53 | 54 | ## Contributing ## 55 | 56 | If you find problems with this library please take the time to report the issue. This helps you by increasing the chance the issue will be fixed. It helps motivate me by letting me know the library is being used. It helps everyone when the fixed issue creates a stronger codebase. 57 | 58 | To report an issue, use the [cl-bayesnet issue tracker](https://github.com/lhope/cl-bayesnet/issues) at github.com. 59 | 60 | For issue fixes and improvements, I prefer pull requests. Simple one or two liner fixes are okay over email for now. 61 | -------------------------------------------------------------------------------- /cl-bayesnet.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP -*- 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;; cl-bayesnet - ASDF system definition for the cl-bayesnet system. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (asdf:defsystem :cl-bayesnet 25 | :name "cl-bayesnet" 26 | :author "Lucas Hope " 27 | :version "0.1.0" 28 | :maintainer "Lucas Hope " 29 | :description "A Common Lisp Bayesian Network Inference Engine" 30 | :license "LLGPL" 31 | :depends-on (:s-xml 32 | #-cl-bayesnet-no-cffi :trivial-shell 33 | #-cl-bayesnet-no-cffi :cffi) 34 | :serial t 35 | :components ((:module :src 36 | :serial t 37 | :components ((:file "packages") 38 | (:file "utils") 39 | (:file "tries") 40 | (:file "bn-utils") 41 | (:file "bn") 42 | (:file "parse-network") 43 | (:file "clique-tree") 44 | (:file "message") 45 | (:file "evidence") 46 | (:file "compiler") 47 | (:file "emit-c") 48 | (:file "test"))))) 49 | -------------------------------------------------------------------------------- /make-api-doc.sbcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/sbcl --script 2 | 3 | ;; The default quicklisp location. 4 | #-quicklisp 5 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" 6 | (user-homedir-pathname)))) 7 | (when (probe-file quicklisp-init) 8 | (load quicklisp-init))) 9 | 10 | (require 'sb-introspect) ;; workaround, cl-api should include this. 11 | (ql:quickload '("cl-bayesnet" "cl-api")) 12 | 13 | (unless (cdr sb-ext:*posix-argv*) 14 | (format t "~&Usage: make-api-doc.sbcl ~2%")) 15 | 16 | (defparameter *doc-dir* 17 | (let ((arg (second sb-ext:*posix-argv*))) 18 | (if arg 19 | (make-pathname :directory arg) 20 | ""))) 21 | 22 | (cl-api:api-gen :cl-bayesnet *doc-dir* 23 | :exclude-const (constantly t) 24 | :exclude-var (constantly t) 25 | :exclude-class (constantly t) 26 | :exclude-cond (constantly t) 27 | :exclude-macro nil 28 | ) 29 | 30 | (format t "~2%") 31 | -------------------------------------------------------------------------------- /nets/alarm.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 9 | 10 | 11 | 12 | 13 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | ]> 27 | 28 | 29 | 30 | 31 | Alarm 32 | 33 | 34 | 35 | Hypovolemia 36 | True 37 | False 38 | position = (54, 35) 39 | 40 | 41 | 42 | StrokeVolume 43 | Low 44 | Normal 45 | High 46 | position = (184, 113) 47 | 48 | 49 | 50 | LVFailure 51 | True 52 | False 53 | position = (145, 36) 54 | 55 | 56 | 57 | LVEDVolume 58 | Low 59 | Normal 60 | High 61 | position = (68, 114) 62 | 63 | 64 | 65 | PCWP 66 | Low 67 | Normal 68 | High 69 | position = (111, 177) 70 | 71 | 72 | 73 | CVP 74 | Low 75 | Normal 76 | High 77 | position = (32, 179) 78 | 79 | 80 | 81 | History 82 | True 83 | False 84 | position = (238, 61) 85 | 86 | 87 | 88 | MinVolSet 89 | Low 90 | Normal 91 | High 92 | position = (564, 38) 93 | 94 | 95 | 96 | VentMach 97 | Zero 98 | Low 99 | Normal 100 | High 101 | position = (640, 86) 102 | 103 | 104 | 105 | Disconnect 106 | True 107 | False 108 | position = (738, 86) 109 | 110 | 111 | 112 | VentTube 113 | Zero 114 | Low 115 | Normal 116 | High 117 | position = (682, 168) 118 | 119 | 120 | 121 | KinkedTube 122 | True 123 | False 124 | position = (564, 172) 125 | 126 | 127 | 128 | Press 129 | Zero 130 | Low 131 | Normal 132 | High 133 | position = (722, 253) 134 | 135 | 136 | 137 | ErrLowOutput 138 | True 139 | False 140 | position = (226, 237) 141 | 142 | 143 | 144 | HRBP 145 | Low 146 | Normal 147 | High 148 | position = (229, 305) 149 | 150 | 151 | 152 | ErrCauter 153 | True 154 | False 155 | position = (366, 278) 156 | 157 | 158 | 159 | HREKG 160 | Low 161 | Normal 162 | High 163 | position = (289, 305) 164 | 165 | 166 | 167 | HRSat 168 | Low 169 | Normal 170 | High 171 | position = (220, 396) 172 | 173 | 174 | 175 | BP 176 | Low 177 | Normal 178 | High 179 | position = (154, 396) 180 | 181 | 182 | 183 | CO 184 | Low 185 | Normal 186 | High 187 | position = (195, 176) 188 | 189 | 190 | 191 | HR 192 | Low 193 | Normal 194 | High 195 | position = (308, 171) 196 | 197 | 198 | 199 | TPR 200 | Low 201 | Normal 202 | High 203 | position = (120, 301) 204 | 205 | 206 | 207 | Anaphylaxis 208 | True 209 | False 210 | position = (31, 239) 211 | 212 | 213 | 214 | InsuffAnesth 215 | True 216 | False 217 | position = (329, 37) 218 | 219 | 220 | 221 | PAP 222 | Low 223 | Normal 224 | High 225 | position = (1045, 292) 226 | 227 | 228 | 229 | PulmEmbolus 230 | True 231 | False 232 | position = (969, 258) 233 | 234 | 235 | 236 | FiO2 237 | Low 238 | Normal 239 | position = (1014, 162) 240 | 241 | 242 | 243 | Catechol 244 | Normal 245 | High 246 | position = (329, 107) 247 | 248 | 249 | 250 | SaO2 251 | Low 252 | Normal 253 | High 254 | position = (926, 387) 255 | 256 | 257 | 258 | Shunt 259 | Normal 260 | High 261 | position = (894, 293) 262 | 263 | 264 | 265 | PVSat 266 | Low 267 | Normal 268 | High 269 | position = (949, 197) 270 | 271 | 272 | 273 | MinVol 274 | Zero 275 | Low 276 | Normal 277 | High 278 | position = (754, 387) 279 | 280 | 281 | 282 | ExpCO2 283 | Zero 284 | Low 285 | Normal 286 | High 287 | position = (530, 393) 288 | 289 | 290 | 291 | ArtCO2 292 | Low 293 | Normal 294 | High 295 | position = (474, 277) 296 | 297 | 298 | 299 | VentAlv 300 | Zero 301 | Low 302 | Normal 303 | High 304 | position = (881, 165) 305 | 306 | 307 | 308 | VentLung 309 | Zero 310 | Low 311 | Normal 312 | High 313 | position = (706, 344) 314 | 315 | 316 | 317 | Intubation 318 | Normal 319 | Esophageal 320 | OneSided 321 | position = (843, 86) 322 | 323 | 324 | 325 | 326 | 327 | Hypovolemia 328 | 0.2 0.8
329 | 330 | 331 | 332 | StrokeVolume 333 | LVFailure 334 | Hypovolemia 335 | 0.98 0.01 0.01 0.5 0.49 0.01 0.95 0.04 0.01 0.05 0.9 0.05
336 | 337 | 338 | 339 | LVFailure 340 | 0.05 0.95
341 | 342 | 343 | 344 | LVEDVolume 345 | Hypovolemia 346 | LVFailure 347 | 0.95 0.04 0.01 0.98 0.01 0.01 0.01 0.09 0.9 0.05 0.9 0.05
348 | 349 | 350 | 351 | PCWP 352 | LVEDVolume 353 | 0.95 0.04 0.01 0.04 0.95 0.01 0.01 0.04 0.95
354 | 355 | 356 | 357 | CVP 358 | LVEDVolume 359 | 0.95 0.04 0.01 0.04 0.95 0.01 0.01 0.29 0.7
360 | 361 | 362 | 363 | History 364 | LVFailure 365 | 0.9 0.1 0.01 0.99
366 | 367 | 368 | 369 | MinVolSet 370 | 0.01 0.98 0.01
371 | 372 | 373 | 374 | VentMach 375 | MinVolSet 376 | 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97
377 | 378 | 379 | 380 | Disconnect 381 | 0.05 0.95
382 | 383 | 384 | 385 | VentTube 386 | VentMach 387 | Disconnect 388 | 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.01 0.97 0.01 0.97 0.01 0.01 0.01 0.01 0.01 0.01 0.97
389 | 390 | 391 | 392 | KinkedTube 393 | 0.04 0.96
394 | 395 | 396 | 397 | Press 398 | KinkedTube 399 | Intubation 400 | VentTube 401 | 0.97 0.01 0.01 0.01 0.01 0.49 0.3 0.2 0.01 0.01 0.08 0.9 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.1 0.84 0.05 0.01 0.05 0.25 0.25 0.45 0.01 0.15 0.25 0.59 0.97 0.01 0.01 0.01 0.01 0.29 0.3 0.4 0.01 0.01 0.08 0.9 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.4 0.58 0.01 0.01 0.2 0.75 0.04 0.01 0.2 0.7 0.09 0.01 0.97 0.01 0.01 0.01 0.01 0.9 0.08 0.01 0.01 0.01 0.38 0.6 0.01 0.01 0.01 0.97
402 | 403 | 404 | 405 | ErrLowOutput 406 | 0.05 0.95
407 | 408 | 409 | 410 | HRBP 411 | ErrLowOutput 412 | HR 413 | 0.98 0.01 0.01 0.4 0.59 0.01 0.3 0.4 0.3 0.98 0.01 0.01 0.01 0.98 0.01 0.01 0.01 0.98
414 | 415 | 416 | 417 | ErrCauter 418 | 0.1 0.9
419 | 420 | 421 | 422 | HREKG 423 | HR 424 | ErrCauter 425 | 0.333333 0.333333 0.333333 0.98 0.01 0.01 0.333333 0.333333 0.333333 0.01 0.98 0.01 0.333333 0.333333 0.333333 0.01 0.01 0.98
426 | 427 | 428 | 429 | HRSat 430 | HR 431 | ErrCauter 432 | 0.333333 0.333333 0.333333 0.98 0.01 0.01 0.333333 0.333333 0.333333 0.01 0.98 0.01 0.333333 0.333333 0.333333 0.01 0.01 0.98
433 | 434 | 435 | 436 | BP 437 | CO 438 | TPR 439 | 0.98 0.01 0.01 0.98 0.01 0.01 0.3 0.6 0.1 0.98 0.01 0.01 0.1 0.85 0.05 0.05 0.4 0.55 0.9 0.09 0.01 0.05 0.2 0.75 0.01 0.09 0.9
440 | 441 | 442 | 443 | CO 444 | HR 445 | StrokeVolume 446 | 0.98 0.01 0.01 0.95 0.04 0.01 0.3 0.69 0.01 0.95 0.04 0.01 0.04 0.95 0.01 0.01 0.3 0.69 0.8 0.19 0.01 0.01 0.04 0.95 0.01 0.01 0.98
447 | 448 | 449 | 450 | HR 451 | Catechol 452 | 0.1 0.89 0.01 0.01 0.09 0.9
453 | 454 | 455 | 456 | TPR 457 | Anaphylaxis 458 | 0.98 0.01 0.01 0.3 0.4 0.3
459 | 460 | 461 | 462 | Anaphylaxis 463 | 0.01 0.99
464 | 465 | 466 | 467 | InsuffAnesth 468 | 0.2 0.8
469 | 470 | 471 | 472 | PAP 473 | PulmEmbolus 474 | 0.01 0.19 0.8 0.05 0.9 0.05
475 | 476 | 477 | 478 | PulmEmbolus 479 | 0.01 0.99
480 | 481 | 482 | 483 | FiO2 484 | 0.01 0.99
485 | 486 | 487 | 488 | Catechol 489 | InsuffAnesth 490 | SaO2 491 | TPR 492 | ArtCO2 493 | 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.01 0.99 0.01 0.99 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.05 0.95 0.05 0.95 0.01 0.99 0.1 0.9 0.1 0.9 0.1 0.9 0.95 0.05 0.95 0.05 0.3 0.7 0.95 0.05 0.95 0.05 0.3 0.7 0.95 0.05 0.95 0.05 0.3 0.7 0.99 0.01 0.99 0.01 0.99 0.01 0.95 0.05 0.99 0.01 0.3 0.7
494 | 495 | 496 | 497 | SaO2 498 | Shunt 499 | PVSat 500 | 0.98 0.01 0.01 0.01 0.98 0.01 0.01 0.01 0.98 0.98 0.01 0.01 0.98 0.01 0.01 0.69 0.3 0.01
501 | 502 | 503 | 504 | Shunt 505 | PulmEmbolus 506 | Intubation 507 | 0.1 0.9 0.1 0.9 0.01 0.99 0.95 0.05 0.95 0.05 0.05 0.95
508 | 509 | 510 | 511 | PVSat 512 | VentAlv 513 | FiO2 514 | 0.98 0.01 0.01 0.98 0.01 0.01 0.98 0.01 0.01 0.98 0.01 0.01 0.95 0.04 0.01 0.01 0.95 0.04 0.95 0.04 0.01 0.01 0.01 0.98
515 | 516 | 517 | 518 | MinVol 519 | VentLung 520 | Intubation 521 | 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.6 0.38 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.5 0.48 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.5 0.48 0.01 0.01 0.01 0.01 0.01 0.97
522 | 523 | 524 | 525 | ExpCO2 526 | ArtCO2 527 | VentLung 528 | 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.97 0.01 0.01 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97
529 | 530 | 531 | 532 | ArtCO2 533 | VentAlv 534 | 0.01 0.01 0.98 0.01 0.01 0.98 0.04 0.92 0.04 0.9 0.09 0.01
535 | 536 | 537 | 538 | VentAlv 539 | Intubation 540 | VentLung 541 | 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.03 0.95 0.01 0.01 0.01 0.94 0.04 0.01 0.01 0.88 0.1 0.01
542 | 543 | 544 | 545 | VentLung 546 | KinkedTube 547 | VentTube 548 | Intubation 549 | 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.95 0.03 0.01 0.01 0.97 0.01 0.01 0.01 0.95 0.03 0.01 0.01 0.4 0.58 0.01 0.01 0.97 0.01 0.01 0.01 0.5 0.48 0.01 0.01 0.3 0.68 0.01 0.01 0.97 0.01 0.01 0.01 0.3 0.68 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.01 0.97 0.01 0.01 0.01 0.01 0.01 0.97 0.01 0.01 0.01 0.01 0.97 0.97 0.01 0.01 0.01 0.01 0.01 0.01 0.97
550 | 551 | 552 | 553 | Intubation 554 | 0.92 0.03 0.05
555 | 556 | 557 | 558 | 559 | 560 | -------------------------------------------------------------------------------- /nets/asia.dne: -------------------------------------------------------------------------------- 1 | // ~->[DNET-1]->~ 2 | 3 | // File created by an unlicensed user using Netica 2.17 on Jun 08, 2003 at 16:38:37. 4 | 5 | bnet Asia { 6 | autoupdate = TRUE; 7 | comment = "\n\ 8 | Chest Clinic Copyright 1998 Norsys Software Corp.\n\n\ 9 | This belief network is also known as \"Asia\", and is an example which is popular \n\ 10 | for introducing belief networks. It is from Lauritzen&Spiegelhalter88 (see below).\n\ 11 | It is for example purposes only, and should not be used for real decision making.\n\n\ 12 | It is a simplified version of a network that could be used to diagnose patients arriving\n\ 13 | at a clinic. Each node in the network corresponds to some condition of the patient,\n\ 14 | for example, \"Visit to Asia\" indicates whether the patient recently visited Asia.\n\ 15 | To diagnose a patient, values are entered for nodes when they are known. \n\ 16 | Netica then automatically re-calculates the probabilities for all the other nodes,\n\ 17 | based on the relationships between them. The links between the nodes indicate how the\n\ 18 | relationships between the nodes are structured.\n\n\ 19 | The two top nodes are for predispositions which influence the likelihood of the diseases. \n\ 20 | Those diseases appear in the row below them. At the bottom are symptoms of the diseases.\n\ 21 | To a large degree, the links of the network correspond to causation. \n\ 22 | This is a common structure for diagnostic networks: predisposition nodes at the top, \n\ 23 | with links to nodes representing internal conditions and failure states, which in turn have\n\ 24 | links to nodes for observables. Often there are many layers of nodes representing\n\ 25 | internal conditions, with links between them representing their complex inter-relationships.\n\n\ 26 | This network is from Lauritzen, Steffen L. and David J. Spiegelhalter (1988) \"Local \n\ 27 | computations with probabilities on graphical structures and their application to expert \n\ 28 | systems\" in Journal Royal Statistics Society B, 50(2), 157-194.\n\n\n\ 29 | TUTORIAL: Basic Probabilistic Inference\n\ 30 | --------\n\n\ 31 | Keep in mind when doing tutorials that there is a great deal of assitance available\n\ 32 | from Netica's onscreen help, often about the exact networks of the tutorials.\n\ 33 | For this example, choose Help->Contents/Index, click on the Index tab, type in\n\ 34 | \"Asia\", and go to the example.\n\n\ 35 | All the information contained in a belief network can be observed by examining 3 things.\n\n\ 36 | First, there is the network structure, consisting of the nodes and their links,\n\ 37 | which you can see in the network diagram currently being displayed.\n\n\ 38 | Second, are the properties of each node, which you can see in their node dialog box,\n\ 39 | obtained by double-clicking on the node.\n\n\ 40 | Third, are the actual relationships between the nodes, which you can see by \n\ 41 | single-clicking on a node to select it, then choosing Relation->View/Edit. \n\ 42 | The relationship may be probabilistic or functional. For example, click on \n\ 43 | \"Lung Cancer\", and then choose Relation->View/Edit, to see its probabilistic relation \n\ 44 | with Smoking (the numbers are for example purposes only, and may not reflect reality).\n\ 45 | If you click on \"Tuberculosis or Cancer\", and choose Relation->View/Edit, you can see\n\ 46 | its functional dependence on Tuberculosis and Lung Cancer.\n\n\ 47 | To compile the network for use, click on its window to make it active,\n\ 48 | and choose Network->Compile. \n\n\ 49 | The appropriate data structures for fast inference have been built internally. \n\ 50 | The bars in each node have darkened, indicating that they and the numbers beside them\n\ 51 | are now valid data. The indicate the probabilities of each state of the node.\n\n\ 52 | Suppose we want to \"diagnose\" a new patient. When she first enters the clinic,\n\ 53 | without having any information about her, we believe she has lung cancer with a\n\ 54 | probability of 5.5%, as can be seen on the Lung Cancer node (the number may be higher\n\ 55 | than that for the general population, because something has led her to the chest clinic).\n\n\ 56 | If she has an abnormal x-ray, that information can be entered by clicking on the word\n\ 57 | \"Abnormal\" of the \"XRay Result\" node (in a real-world belief network, you would probably\n\ 58 | be able to enter in exactly what way the x-ray was \"abnormal\").\n\n\ 59 | All the probability numbers and bars will change to take into account the finding.\n\ 60 | Now the probability that she has lung cancer has increased to 48.9%.\n\n\ 61 | If you further indicate that she has made a visit to asia recently, by clicking on\n\ 62 | \"Visit\", the probability of lung cancer decreases to 37.1%, because the abnormal XRay is \n\ 63 | partially explained away by a greater chance of Tuberculosis (which she could \n\ 64 | catch in Asia). Old fashioned medical expert systems had problems with this kind of \n\ 65 | reasoning, since each of the findings \"Abnormal XRay\" and \"Visit to Asia\" by themselves\n\ 66 | increase or leave the same the probability of lung cancer.\n\n\ 67 | You can try entering and changing some more findings. To remove a finding, simply click\n\ 68 | on its name again. If you want to remove all the findings (a new patient has just walked\n\ 69 | in), choose Network->Remove Findings.\n\n\n\n\n\ 70 | "; 71 | whenchanged = 1055115507; 72 | 73 | visual V1 { 74 | defdispform = BELIEFBARS; 75 | nodelabeling = TITLE; 76 | NodeMaxNumEntries = 50; 77 | nodefont = font {shape= "Palatino"; size= 14;}; 78 | linkfont = font {shape= "Arial"; size= 9;}; 79 | windowposn = (22, 22, 870, 589); 80 | CommentShowing = TRUE; 81 | CommentWindowPosn = (22, 491, 815, 729); 82 | resolution = 72; 83 | drawingbounds = (1104, 730); 84 | showpagebreaks = FALSE; 85 | usegrid = TRUE; 86 | gridspace = (6, 6); 87 | PrinterSetting A { 88 | margins = (1270, 1270, 1270, 1270); 89 | landscape = FALSE; 90 | magnify = 1; 91 | }; 92 | }; 93 | 94 | node VisitAsia { 95 | kind = NATURE; 96 | discrete = TRUE; 97 | states = (Visit, No_Visit); 98 | parents = (); 99 | probs = 100 | // Visit No Visit 101 | (0.01, 0.99); 102 | title = "Visit To Asia"; 103 | comment = "Patient has recently visited Asia"; 104 | whenchanged = 904512863; 105 | belief = (0.01, 0.99); 106 | visual V1 { 107 | center = (126, 54); 108 | height = 7; 109 | }; 110 | }; 111 | 112 | node Tuberculosis { 113 | kind = NATURE; 114 | discrete = TRUE; 115 | states = (Present, Absent); 116 | parents = (VisitAsia); 117 | probs = 118 | // Present Absent // VisitAsia 119 | ((0.05, 0.95), // Visit 120 | (0.01, 0.99)); // No Visit ; 121 | title = "Tuberculosis"; 122 | belief = (0.0104, 0.9896); 123 | visual V1 { 124 | center = (126, 156); 125 | height = 1; 126 | }; 127 | }; 128 | 129 | node Smoking { 130 | kind = NATURE; 131 | discrete = TRUE; 132 | states = (Smoker, NonSmoker); 133 | parents = (); 134 | probs = 135 | // Smoker NonSmoker 136 | (0.5, 0.5); 137 | title = "Smoking"; 138 | belief = (0.5, 0.5); 139 | visual V1 { 140 | center = (510, 54); 141 | height = 8; 142 | }; 143 | }; 144 | 145 | node Cancer { 146 | kind = NATURE; 147 | discrete = TRUE; 148 | states = (Present, Absent); 149 | parents = (Smoking); 150 | probs = 151 | // Present Absent // Smoking 152 | ((0.1, 0.9), // Smoker 153 | (0.01, 0.99)); // NonSmoker ; 154 | title = "Lung Cancer"; 155 | belief = (0.055, 0.945); 156 | visual V1 { 157 | center = (384, 156); 158 | height = 4; 159 | link 1 { 160 | path = ((466, 91), (429, 120)); 161 | }; 162 | }; 163 | }; 164 | 165 | node TbOrCa { 166 | kind = NATURE; 167 | discrete = TRUE; 168 | states = (True, False); 169 | parents = (Tuberculosis, Cancer); 170 | functable = 171 | // Tuberculosis Cancer 172 | ((True, // Present Present 173 | True), // Present Absent 174 | (True, // Absent Present 175 | False)); // Absent Absent ; 176 | title = "Tuberculosis or Cancer"; 177 | whenchanged = 2147483647; 178 | belief = (0.064828, 0.935172); 179 | visual V1 { 180 | center = (264, 264); 181 | height = 3; 182 | link 1 { 183 | path = ((171, 193), (217, 228)); 184 | }; 185 | }; 186 | }; 187 | 188 | node XRay { 189 | kind = NATURE; 190 | discrete = TRUE; 191 | states = (Abnormal, Normal); 192 | parents = (TbOrCa); 193 | probs = 194 | // Abnormal Normal // TbOrCa 195 | ((0.98, 0.02), // True 196 | (0.05, 0.95)); // False ; 197 | title = "XRay Result"; 198 | whenchanged = 904512850; 199 | belief = (0.11029, 0.88971); 200 | visual V1 { 201 | center = (138, 366); 202 | height = 2; 203 | }; 204 | }; 205 | 206 | node Bronchitis { 207 | kind = NATURE; 208 | discrete = TRUE; 209 | states = (Present, Absent); 210 | parents = (Smoking); 211 | probs = 212 | // Present Absent // Smoking 213 | ((0.6, 0.4), // Smoker 214 | (0.3, 0.7)); // NonSmoker ; 215 | title = "Bronchitis"; 216 | belief = (0.45, 0.55); 217 | visual V1 { 218 | center = (636, 156); 219 | height = 6; 220 | link 1 { 221 | path = ((554, 91), (591, 120)); 222 | }; 223 | }; 224 | }; 225 | 226 | node Dyspnea { 227 | kind = NATURE; 228 | discrete = TRUE; 229 | chance = CHANCE; 230 | states = (Present, Maybe, Absent); 231 | parents = (TbOrCa, Bronchitis); 232 | probs = 233 | // Present Maybe Absent // TbOrCa Bronchitis 234 | (((0.1, 0.1, 0.8), // True Present 235 | (0.1, 0.1, 0.8)), // True Absent 236 | ((0.1, 0.1, 0.8), // False Present 237 | (0.1, 0.1, 0.8))); // False Absent ; 238 | title = "Dyspnea"; 239 | comment = "Shortness of breath."; 240 | whenchanged = 1055115507; 241 | belief = (0.1, 0.1, 0.8); 242 | visual V1 { 243 | center = (426, 366); 244 | height = 5; 245 | link 1 { 246 | path = ((321, 301), (351, 319)); 247 | }; 248 | }; 249 | }; 250 | 251 | ElimOrder = (VisitAsia, XRay, Tuberculosis, Smoking, Cancer, TbOrCa, Bronchitis, Dyspnea); 252 | }; 253 | -------------------------------------------------------------------------------- /nets/chess1.dne: -------------------------------------------------------------------------------- 1 | // ~->[DNET-1]->~ 2 | 3 | // File created by someone at MonashU using Netica 2.15 on 08/26/07 at 08:56:23. 4 | 5 | bnet Net { 6 | autoupdate = FALSE; 7 | comment = "Network 1/27 generated by CaMML on Sun Aug 26 08:56:23 EST 2007\n\ 8 | Dataset: chess\n\ 9 | Weight: 0.9680743820670314\n\ 10 | "; 11 | whenchanged = 1188082583; 12 | 13 | node A13 { 14 | kind = NATURE; 15 | discrete = TRUE; 16 | chance = CHANCE; 17 | states = (v_1, v_2); 18 | parents = (); 19 | probs = 20 | // v 1 v 2 21 | (0.9393116, 0.06068841); 22 | }; 23 | 24 | node A10 { 25 | kind = NATURE; 26 | discrete = TRUE; 27 | chance = CHANCE; 28 | states = (v_1, v_2); 29 | parents = (); 30 | probs = 31 | // v 1 v 2 32 | (0.9701087, 0.0298913); 33 | }; 34 | 35 | node A16 { 36 | kind = NATURE; 37 | discrete = TRUE; 38 | chance = CHANCE; 39 | states = (v_1, v_2); 40 | parents = (A10); 41 | probs = 42 | // v 1 v 2 // A10 43 | ((0.9113806, 0.0886194), // v 1 44 | (0.5, 0.5)); // v 2 ; 45 | }; 46 | 47 | node A12 { 48 | kind = NATURE; 49 | discrete = TRUE; 50 | chance = CHANCE; 51 | states = (v_1, v_2); 52 | parents = (A13, A16); 53 | probs = 54 | // v 1 v 2 // A13 A16 55 | (((0.7467672, 0.2532327), // v 1 v 1 56 | (0.9910714, 0.008928572)), // v 1 v 2 57 | ((0.9852941, 0.01470588), // v 2 v 1 58 | (0.5, 0.5))); // v 2 v 2 ; 59 | }; 60 | 61 | node A4 { 62 | kind = NATURE; 63 | discrete = TRUE; 64 | chance = CHANCE; 65 | states = (v_1, v_2); 66 | parents = (A12); 67 | probs = 68 | // v 1 v 2 // A12 69 | ((0.854023, 0.145977), // v 1 70 | (0.5889831, 0.4110169)); // v 2 ; 71 | }; 72 | 73 | node A8 { 74 | kind = NATURE; 75 | discrete = TRUE; 76 | chance = CHANCE; 77 | states = (v_1, v_2); 78 | parents = (A4); 79 | probs = 80 | // v 1 v 2 // A4 81 | ((0.7698413, 0.2301587), // v 1 82 | (0.9508929, 0.04910714)); // v 2 ; 83 | }; 84 | 85 | node A25 { 86 | kind = NATURE; 87 | discrete = TRUE; 88 | chance = CHANCE; 89 | states = (v_1, v_2); 90 | parents = (); 91 | probs = 92 | // v 1 v 2 93 | (0.9773551, 0.02264493); 94 | }; 95 | 96 | node A23 { 97 | kind = NATURE; 98 | discrete = TRUE; 99 | chance = CHANCE; 100 | states = (v_1, v_2); 101 | parents = (A12, A25); 102 | probs = 103 | // v 1 v 2 // A12 A25 104 | (((0.9917647, 0.008235294), // v 1 v 1 105 | (0.5909091, 0.4090909)), // v 1 v 2 106 | ((0.8836207, 0.1163793), // v 2 v 1 107 | (0.1666667, 0.8333333))); // v 2 v 2 ; 108 | }; 109 | 110 | node A2 { 111 | kind = NATURE; 112 | discrete = TRUE; 113 | chance = CHANCE; 114 | states = (v_1, v_2); 115 | parents = (A23); 116 | probs = 117 | // v 1 v 2 // A23 118 | ((0.5801887, 0.4198113), // v 1 119 | (0.9782609, 0.02173913)); // v 2 ; 120 | }; 121 | 122 | node A6 { 123 | kind = NATURE; 124 | discrete = TRUE; 125 | chance = CHANCE; 126 | states = (v_1, v_2); 127 | parents = (); 128 | probs = 129 | // v 1 v 2 130 | (0.9483696, 0.05163043); 131 | }; 132 | 133 | node A7 { 134 | kind = NATURE; 135 | discrete = TRUE; 136 | chance = CHANCE; 137 | states = (v_1, v_2); 138 | parents = (A6); 139 | probs = 140 | // v 1 v 2 // A6 141 | ((0.9570611, 0.04293893), // v 1 142 | (0.637931, 0.362069)); // v 2 ; 143 | }; 144 | 145 | node A30 { 146 | kind = NATURE; 147 | discrete = TRUE; 148 | chance = CHANCE; 149 | states = (v_1, v_2); 150 | parents = (); 151 | probs = 152 | // v 1 v 2 153 | (0.9646739, 0.03532609); 154 | }; 155 | 156 | node A5 { 157 | kind = NATURE; 158 | discrete = TRUE; 159 | chance = CHANCE; 160 | states = (v_1, v_2); 161 | parents = (A7, A13, A16, A30); 162 | probs = 163 | // v 1 v 2 // A7 A13 A16 A30 164 | (((((0.6719128, 0.3280872), // v 1 v 1 v 1 v 1 165 | (0.975, 0.025)), // v 1 v 1 v 1 v 2 166 | ((0.9910714, 0.008928572), // v 1 v 1 v 2 v 1 167 | (0.5, 0.5))), // v 1 v 1 v 2 v 2 168 | (((0.9852941, 0.01470588), // v 1 v 2 v 1 v 1 169 | (0.5, 0.5)), // v 1 v 2 v 1 v 2 170 | ((0.5, 0.5), // v 1 v 2 v 2 v 1 171 | (0.5, 0.5)))), // v 1 v 2 v 2 v 2 172 | ((((0.9848485, 0.01515152), // v 2 v 1 v 1 v 1 173 | (0.5, 0.5)), // v 2 v 1 v 1 v 2 174 | ((0.5, 0.5), // v 2 v 1 v 2 v 1 175 | (0.5, 0.5))), // v 2 v 1 v 2 v 2 176 | (((0.5, 0.5), // v 2 v 2 v 1 v 1 177 | (0.5, 0.5)), // v 2 v 2 v 1 v 2 178 | ((0.5, 0.5), // v 2 v 2 v 2 v 1 179 | (0.5, 0.5))))); // v 2 v 2 v 2 v 2 ; 180 | }; 181 | 182 | node A29 { 183 | kind = NATURE; 184 | discrete = TRUE; 185 | chance = CHANCE; 186 | states = (v_1, v_2); 187 | parents = (A5, A6); 188 | probs = 189 | // v 1 v 2 // A5 A6 190 | (((0.9961439, 0.003856041), // v 1 v 1 191 | (0.8448276, 0.1551724)), // v 1 v 2 192 | ((0.8345588, 0.1654412), // v 2 v 1 193 | (0.5, 0.5))); // v 2 v 2 ; 194 | }; 195 | 196 | node A24 { 197 | kind = NATURE; 198 | discrete = TRUE; 199 | chance = CHANCE; 200 | states = (v_1, v_2); 201 | parents = (A29); 202 | probs = 203 | // v 1 v 2 // A29 204 | ((0.9533333, 0.04666667), // v 1 205 | (0.6964286, 0.3035714)); // v 2 ; 206 | }; 207 | 208 | node A32 { 209 | kind = NATURE; 210 | discrete = TRUE; 211 | chance = CHANCE; 212 | states = (v_1, v_2); 213 | parents = (); 214 | probs = 215 | // v 1 v 2 216 | (0.9827899, 0.01721014); 217 | }; 218 | 219 | node A27 { 220 | kind = NATURE; 221 | discrete = TRUE; 222 | chance = CHANCE; 223 | states = (v_1, v_2); 224 | parents = (A32); 225 | probs = 226 | // v 1 v 2 // A32 227 | ((0.9843462, 0.01565378), // v 1 228 | (0.55, 0.45)); // v 2 ; 229 | }; 230 | 231 | node A28 { 232 | kind = NATURE; 233 | discrete = TRUE; 234 | chance = CHANCE; 235 | states = (v_1, v_2); 236 | parents = (); 237 | probs = 238 | // v 1 v 2 239 | (0.9628623, 0.03713768); 240 | }; 241 | 242 | node A31 { 243 | kind = NATURE; 244 | discrete = TRUE; 245 | chance = CHANCE; 246 | states = (v_1, v_2); 247 | parents = (A4, A28); 248 | probs = 249 | // v 1 v 2 // A4 A28 250 | (((0.9847775, 0.01522248), // v 1 v 1 251 | (0.7, 0.3)), // v 1 v 2 252 | ((0.8160377, 0.1839623), // v 2 v 1 253 | (0.5, 0.5))); // v 2 v 2 ; 254 | }; 255 | 256 | node class { 257 | kind = NATURE; 258 | discrete = TRUE; 259 | chance = CHANCE; 260 | states = (v_0, v_1); 261 | parents = (A2, A12, A24, A27, A31); 262 | probs = 263 | // v 0 v 1 // A2 A12 A24 A27 A31 264 | ((((((0.4147982, 0.5852018), // v 1 v 1 v 1 v 1 v 1 265 | (0.71875, 0.28125)), // v 1 v 1 v 1 v 1 v 2 266 | ((0.9285714, 0.07142857), // v 1 v 1 v 1 v 2 v 1 267 | (0.5, 0.5))), // v 1 v 1 v 1 v 2 v 2 268 | (((0.9117647, 0.0882353), // v 1 v 1 v 2 v 1 v 1 269 | (0.5, 0.5)), // v 1 v 1 v 2 v 1 v 2 270 | ((0.5, 0.5), // v 1 v 1 v 2 v 2 v 1 271 | (0.5, 0.5)))), // v 1 v 1 v 2 v 2 v 2 272 | ((((0.05833333, 0.9416667), // v 1 v 2 v 1 v 1 v 1 273 | (0.0625, 0.9375)), // v 1 v 2 v 1 v 1 v 2 274 | ((0.5, 0.5), // v 1 v 2 v 1 v 2 v 1 275 | (0.5, 0.5))), // v 1 v 2 v 1 v 2 v 2 276 | (((0.9, 0.1), // v 1 v 2 v 2 v 1 v 1 277 | (0.5, 0.5)), // v 1 v 2 v 2 v 1 v 2 278 | ((0.5, 0.5), // v 1 v 2 v 2 v 2 v 1 279 | (0.5, 0.5))))), // v 1 v 2 v 2 v 2 v 2 280 | (((((0.009677419, 0.9903226), // v 2 v 1 v 1 v 1 v 1 281 | (0.8125, 0.1875)), // v 2 v 1 v 1 v 1 v 2 282 | ((0.5, 0.5), // v 2 v 1 v 1 v 2 v 1 283 | (0.5, 0.5))), // v 2 v 1 v 1 v 2 v 2 284 | (((0.05555556, 0.9444444), // v 2 v 1 v 2 v 1 v 1 285 | (0.5, 0.5)), // v 2 v 1 v 2 v 1 v 2 286 | ((0.5, 0.5), // v 2 v 1 v 2 v 2 v 1 287 | (0.5, 0.5)))), // v 2 v 1 v 2 v 2 v 2 288 | ((((0.01219512, 0.9878049), // v 2 v 2 v 1 v 1 v 1 289 | (0.125, 0.875)), // v 2 v 2 v 1 v 1 v 2 290 | ((0.5, 0.5), // v 2 v 2 v 1 v 2 v 1 291 | (0.5, 0.5))), // v 2 v 2 v 1 v 2 v 2 292 | (((0.1, 0.9), // v 2 v 2 v 2 v 1 v 1 293 | (0.5, 0.5)), // v 2 v 2 v 2 v 1 v 2 294 | ((0.5, 0.5), // v 2 v 2 v 2 v 2 v 1 295 | (0.5, 0.5)))))); // v 2 v 2 v 2 v 2 v 2 ; 296 | }; 297 | 298 | node A0 { 299 | kind = NATURE; 300 | discrete = TRUE; 301 | chance = CHANCE; 302 | states = (v_1, v_2); 303 | parents = (A4, A8, class); 304 | probs = 305 | // v 1 v 2 // A4 A8 class 306 | ((((0.6009175, 0.3990826), // v 1 v 1 v 0 307 | (0.8469828, 0.1530172)), // v 1 v 1 v 1 308 | ((0.4333333, 0.5666667), // v 1 v 2 v 0 309 | (0.6761364, 0.3238636))), // v 1 v 2 v 1 310 | (((0.025, 0.975), // v 2 v 1 v 0 311 | (0.8238636, 0.1761364)), // v 2 v 1 v 1 312 | ((0.5, 0.5), // v 2 v 2 v 0 313 | (0.25, 0.75)))); // v 2 v 2 v 1 ; 314 | }; 315 | 316 | node A1 { 317 | kind = NATURE; 318 | discrete = TRUE; 319 | chance = CHANCE; 320 | states = (v_1, v_2); 321 | parents = (A0, class); 322 | probs = 323 | // v 1 v 2 // A0 class 324 | (((0.6041667, 0.3958333), // v 1 v 0 325 | (0.724924, 0.275076)), // v 1 v 1 326 | ((0.5422535, 0.4577465), // v 2 v 0 327 | (0.9939759, 0.006024096))); // v 2 v 1 ; 328 | }; 329 | 330 | node A9 { 331 | kind = NATURE; 332 | discrete = TRUE; 333 | chance = CHANCE; 334 | states = (v_1, v_2); 335 | parents = (A29, A31); 336 | probs = 337 | // v 1 v 2 // A29 A31 338 | (((0.7494929, 0.2505071), // v 1 v 1 339 | (0.9848485, 0.01515152)), // v 1 v 2 340 | ((0.9821429, 0.01785714), // v 2 v 1 341 | (0.5, 0.5))); // v 2 v 2 ; 342 | }; 343 | 344 | node A14 { 345 | kind = NATURE; 346 | discrete = TRUE; 347 | chance = CHANCE; 348 | states = (v_1, v_2); 349 | parents = (A13); 350 | probs = 351 | // v 1 v 2 // A13 352 | ((0.9990366, 9.633912e-4), // v 1 353 | (0.7794118, 0.2205882)); // v 2 ; 354 | }; 355 | 356 | node A15 { 357 | kind = NATURE; 358 | discrete = TRUE; 359 | chance = CHANCE; 360 | states = (v_1, v_2); 361 | parents = (A16); 362 | probs = 363 | // v 1 v 2 // A16 364 | ((0.998994, 0.001006036), // v 1 365 | (0.9196429, 0.08035714)); // v 2 ; 366 | }; 367 | 368 | node A26 { 369 | kind = NATURE; 370 | discrete = TRUE; 371 | chance = CHANCE; 372 | states = (v_1, v_2); 373 | parents = (A23, A25); 374 | probs = 375 | // v 1 v 2 // A23 A25 376 | (((0.9971374, 0.002862595), // v 1 v 1 377 | (0.6428571, 0.3571429)), // v 1 v 2 378 | ((0.7352941, 0.2647059), // v 2 v 1 379 | (0.6428571, 0.3571429))); // v 2 v 2 ; 380 | }; 381 | 382 | node A38 { 383 | kind = NATURE; 384 | discrete = TRUE; 385 | chance = CHANCE; 386 | states = (v_1, v_2); 387 | parents = (); 388 | probs = 389 | // v 1 v 2 390 | (0.9846014, 0.01539855); 391 | }; 392 | 393 | node A3 { 394 | kind = NATURE; 395 | discrete = TRUE; 396 | chance = CHANCE; 397 | states = (v_1, v_2); 398 | parents = (A7, A32, A38); 399 | probs = 400 | // v 1 v 2 // A7 A32 A38 401 | ((((0.2992048, 0.7007952), // v 1 v 1 v 1 402 | (0.8333333, 0.1666667)), // v 1 v 1 v 2 403 | ((0.95, 0.05), // v 1 v 2 v 1 404 | (0.5, 0.5))), // v 1 v 2 v 2 405 | (((0.01515152, 0.9848485), // v 2 v 1 v 1 406 | (0.5, 0.5)), // v 2 v 1 v 2 407 | ((0.5, 0.5), // v 2 v 2 v 1 408 | (0.5, 0.5)))); // v 2 v 2 v 2 ; 409 | }; 410 | 411 | node A11 { 412 | kind = NATURE; 413 | discrete = TRUE; 414 | chance = CHANCE; 415 | states = (v_1, v_2); 416 | parents = (); 417 | probs = 418 | // v 1 v 2 419 | (0.9646739, 0.03532609); 420 | }; 421 | 422 | node A17 { 423 | kind = NATURE; 424 | discrete = TRUE; 425 | chance = CHANCE; 426 | states = (v_1, v_2); 427 | parents = (); 428 | probs = 429 | // v 1 v 2 430 | (0.9882246, 0.01177536); 431 | }; 432 | 433 | node A18 { 434 | kind = NATURE; 435 | discrete = TRUE; 436 | chance = CHANCE; 437 | states = (v_1, v_2); 438 | parents = (); 439 | probs = 440 | // v 1 v 2 441 | (0.995471, 0.004528985); 442 | }; 443 | 444 | node A19 { 445 | kind = NATURE; 446 | discrete = TRUE; 447 | chance = CHANCE; 448 | states = (v_1, v_2); 449 | parents = (); 450 | probs = 451 | // v 1 v 2 452 | (0.9864131, 0.01358696); 453 | }; 454 | 455 | node A20 { 456 | kind = NATURE; 457 | discrete = TRUE; 458 | chance = CHANCE; 459 | states = (v_1, v_2); 460 | parents = (); 461 | probs = 462 | // v 1 v 2 463 | (0.9882246, 0.01177536); 464 | }; 465 | 466 | node A35 { 467 | kind = NATURE; 468 | discrete = TRUE; 469 | chance = CHANCE; 470 | states = (v_1, v_2); 471 | parents = (A20); 472 | probs = 473 | // v 1 v 2 // A20 474 | ((0.9862638, 0.01373626), // v 1 475 | (0.5, 0.5)); // v 2 ; 476 | }; 477 | 478 | node A21 { 479 | kind = NATURE; 480 | discrete = TRUE; 481 | chance = CHANCE; 482 | states = (v_1, v_2); 483 | parents = (); 484 | probs = 485 | // v 1 v 2 486 | (0.9918478, 0.008152174); 487 | }; 488 | 489 | node A22 { 490 | kind = NATURE; 491 | discrete = TRUE; 492 | chance = CHANCE; 493 | states = (v_1, v_2); 494 | parents = (); 495 | probs = 496 | // v 1 v 2 497 | (0.9882246, 0.01177536); 498 | }; 499 | 500 | node A33 { 501 | kind = NATURE; 502 | discrete = TRUE; 503 | chance = CHANCE; 504 | states = (v_1, v_2); 505 | parents = (); 506 | probs = 507 | // v 1 v 2 508 | (0.9628623, 0.03713768); 509 | }; 510 | 511 | node A34 { 512 | kind = NATURE; 513 | discrete = TRUE; 514 | chance = CHANCE; 515 | states = (v_1, v_2); 516 | parents = (); 517 | probs = 518 | // v 1 v 2 519 | (0.9936594, 0.00634058); 520 | }; 521 | 522 | node A36 { 523 | kind = NATURE; 524 | discrete = TRUE; 525 | chance = CHANCE; 526 | states = (v_1, v_2); 527 | parents = (); 528 | probs = 529 | // v 1 v 2 530 | (0.9846014, 0.01539855); 531 | }; 532 | 533 | node A37 { 534 | kind = NATURE; 535 | discrete = TRUE; 536 | chance = CHANCE; 537 | states = (v_1, v_2); 538 | parents = (); 539 | probs = 540 | // v 1 v 2 541 | (0.9827899, 0.01721014); 542 | }; 543 | }; 544 | -------------------------------------------------------------------------------- /nets/disconnected.dne: -------------------------------------------------------------------------------- 1 | // ~->[DNET-1]->~ 2 | 3 | // File created by someone at MonashU using Netica 3.19 on Aug 21, 2007 at 18:05:44. 4 | 5 | bnet disconnected { 6 | AutoCompile = TRUE; 7 | autoupdate = TRUE; 8 | whenchanged = 1187683522; 9 | 10 | visual V1 { 11 | defdispform = BELIEFBARS; 12 | nodelabeling = TITLE; 13 | NodeMaxNumEntries = 50; 14 | nodefont = font {shape= "Arial"; size= 10;}; 15 | linkfont = font {shape= "Arial"; size= 9;}; 16 | windowposn = (22, 22, 734, 491); 17 | resolution = 72; 18 | drawingbounds = (1044, 769); 19 | showpagebreaks = FALSE; 20 | usegrid = TRUE; 21 | gridspace = (6, 6); 22 | NodeSet Node {BuiltIn = 1; Color = 0xc0c0c0;}; 23 | NodeSet Nature {BuiltIn = 1; Color = 0xf8eed2;}; 24 | NodeSet Deterministic {BuiltIn = 1; Color = 0xd3caa6;}; 25 | NodeSet Finding {BuiltIn = 1; Color = 0xc8c8c8;}; 26 | NodeSet Constant {BuiltIn = 1; Color = 0xffffff;}; 27 | NodeSet ConstantValue {BuiltIn = 1; Color = 0xffffb4;}; 28 | NodeSet Utility {BuiltIn = 1; Color = 0xffbdbd;}; 29 | NodeSet Decision {BuiltIn = 1; Color = 0xdee8ff;}; 30 | NodeSet Documentation {BuiltIn = 1; Color = 0xf0fafa;}; 31 | NodeSet Title {BuiltIn = 1; Color = 0xffffff;}; 32 | PrinterSetting A { 33 | margins = (1270, 1270, 1270, 1270); 34 | landscape = FALSE; 35 | magnify = 1; 36 | }; 37 | }; 38 | 39 | node A { 40 | kind = NATURE; 41 | discrete = TRUE; 42 | chance = CHANCE; 43 | numstates = 2; 44 | parents = (); 45 | probs = 46 | // state0 state1 47 | (0.6, 0.4); 48 | whenchanged = 1187683522; 49 | belief = (0.6, 0.4); 50 | visual V1 { 51 | center = (126, 120); 52 | height = 1; 53 | }; 54 | }; 55 | 56 | node B { 57 | kind = NATURE; 58 | discrete = TRUE; 59 | chance = CHANCE; 60 | numstates = 2; 61 | parents = (A); 62 | probs = 63 | // state0 state1 // A 64 | ((0.75, 0.25), // state0 65 | (0.25, 0.75)); // state1 ; 66 | whenchanged = 1187683488; 67 | belief = (0.55, 0.45); 68 | visual V1 { 69 | center = (318, 234); 70 | height = 2; 71 | link 1 { 72 | path = ((171, 148), (272, 207)); 73 | }; 74 | }; 75 | }; 76 | 77 | node C { 78 | kind = NATURE; 79 | discrete = TRUE; 80 | chance = CHANCE; 81 | numstates = 2; 82 | parents = (); 83 | probs = 84 | // state0 state1 85 | (0.2, 0.8); 86 | whenchanged = 1187683508; 87 | belief = (0.2, 0.8); 88 | visual V1 { 89 | center = (522, 162); 90 | height = 3; 91 | }; 92 | }; 93 | ElimOrder = (C, A, B); 94 | }; 95 | -------------------------------------------------------------------------------- /nets/german1.dne: -------------------------------------------------------------------------------- 1 | // ~->[DNET-1]->~ 2 | 3 | // File created by someone at MonashU using Netica 2.15 on 08/26/07 at 08:25:18. 4 | 5 | bnet Net { 6 | autoupdate = FALSE; 7 | comment = "Network 1/9 generated by CaMML on Sun Aug 26 08:25:18 EST 2007\n\ 8 | Dataset: german-mltools.filters.ClassifierDiscretize-D-Rfirst-last-Cweka.classifiers.bayes.AODE \ 9 | -F 1\n\ 10 | Weight: 0.4408276883319852\n\ 11 | "; 12 | whenchanged = 1188080718; 13 | 14 | node other_debtors { 15 | kind = NATURE; 16 | discrete = TRUE; 17 | chance = CHANCE; 18 | states = (A101, A102, A103); 19 | parents = (); 20 | probs = 21 | // A101 A102 A103 22 | (0.9061408, 0.04143784, 0.05242137); 23 | }; 24 | 25 | node personal_status { 26 | kind = NATURE; 27 | discrete = TRUE; 28 | chance = CHANCE; 29 | states = (A91, A92, A93, A94, A95); 30 | parents = (); 31 | probs = 32 | // A91 A92 A93 A94 A95 33 | (0.05037406, 0.3097257, 0.5471322, 0.09226932, 4.987531e-4); 34 | }; 35 | 36 | node housing { 37 | kind = NATURE; 38 | discrete = TRUE; 39 | chance = CHANCE; 40 | states = (A151, A152, A153); 41 | parents = (personal_status); 42 | probs = 43 | // A151 A152 A153 // personal_status 44 | ((0.1262136, 0.8058252, 0.06796116), // A91 45 | (0.3065811, 0.6308186, 0.06260032), // A92 46 | (0.1010009, 0.7434031, 0.155596), // A93 47 | (0.2513369, 0.7326203, 0.01604278), // A94 48 | (0.3333333, 0.3333333, 0.3333333)); // A95 ; 49 | }; 50 | 51 | node property { 52 | kind = NATURE; 53 | discrete = TRUE; 54 | chance = CHANCE; 55 | states = (A121, A122, A123, A124); 56 | parents = (other_debtors, housing); 57 | probs = 58 | // A121 A122 A123 A124 // other_debtors housing 59 | (((0.3113208, 0.254717, 0.3490566, 0.08490566), // A101 A151 60 | (0.2919877, 0.2596302, 0.4044684, 0.04391371), // A101 A152 61 | (0.01428571, 0.01428571, 0.01428571, 0.9571428)), // A101 A153 62 | ((0.2692308, 0.1153846, 0.1923077, 0.4230769), // A102 A151 63 | (0.3392857, 0.2678571, 0.3035714, 0.08928572), // A102 A152 64 | (0.08333334, 0.08333334, 0.08333334, 0.75)), // A102 A153 65 | ((0.2692308, 0.4230769, 0.2692308, 0.03846154), // A103 A151 66 | (0.6785714, 0.2261905, 0.03571429, 0.05952381), // A103 A152 67 | (0.1666667, 0.5, 0.1666667, 0.1666667))); // A103 A153 ; 68 | }; 69 | 70 | node duration { 71 | kind = NATURE; 72 | discrete = TRUE; 73 | chance = CHANCE; 74 | states = (v____inf_6_466767__, v___6_466767_15_141068__, v___15_141068_41_487977__, v___41_487977_inf__); 75 | parents = (property); 76 | probs = 77 | // v inf 6 46676 v 6 466767 15 v 15 141068 41 v 41 487977 in // property 78 | ((0.1285211, 0.4735915, 0.3573944, 0.04049296), // A121 79 | (0.1089744, 0.3568376, 0.4764957, 0.05769231), // A122 80 | (0.03742515, 0.2889222, 0.5943114, 0.07934131), // A123 81 | (0.06089744, 0.2339744, 0.5032051, 0.2019231)); // A124 ; 82 | }; 83 | 84 | node class { 85 | kind = NATURE; 86 | discrete = TRUE; 87 | chance = CHANCE; 88 | states = (v_1, v_2); 89 | parents = (duration); 90 | probs = 91 | // v 1 v 2 // duration 92 | ((0.8855422, 0.1144578), // v inf 6 46676 93 | (0.77, 0.23), // v 6 466767 15 94 | (0.6554192, 0.3445808), // v 15 141068 41 95 | (0.4695122, 0.5304878)); // v 41 487977 in ; 96 | }; 97 | 98 | node check_accnt_status { 99 | kind = NATURE; 100 | discrete = TRUE; 101 | chance = CHANCE; 102 | states = (A11, A12, A13, A14); 103 | parents = (class); 104 | probs = 105 | // A11 A12 A13 A14 // class 106 | ((0.198718, 0.2343305, 0.07051282, 0.4964387), // v 1 107 | (0.4486755, 0.3493378, 0.04801324, 0.1539735)); // v 2 ; 108 | }; 109 | 110 | node savings { 111 | kind = NATURE; 112 | discrete = TRUE; 113 | chance = CHANCE; 114 | states = (A61, A62, A63, A64, A65); 115 | parents = (check_accnt_status); 116 | probs = 117 | // A61 A62 A63 A64 A65 // check_accnt_status 118 | ((0.7938517, 0.04520795, 0.03074141, 0.02350814, 0.1066908), // A11 119 | (0.5616943, 0.174954, 0.04235727, 0.053407, 0.1675875), // A12 120 | (0.6335878, 0.08396947, 0.06870229, 0.05343511, 0.1603053), // A13 121 | (0.482976, 0.09962169, 0.1021438, 0.06431273, 0.2509458)); // A14 ; 122 | }; 123 | 124 | node installment_plans { 125 | kind = NATURE; 126 | discrete = TRUE; 127 | chance = CHANCE; 128 | states = (A141, A142, A143); 129 | parents = (); 130 | probs = 131 | // A141 A142 A143 132 | (0.1392911, 0.04742886, 0.8132801); 133 | }; 134 | 135 | node credit_history { 136 | kind = NATURE; 137 | discrete = TRUE; 138 | chance = CHANCE; 139 | states = (A30, A31, A32, A33, A34); 140 | parents = (installment_plans, class); 141 | probs = 142 | // A30 A31 A32 A33 A34 // installment_plans class 143 | (((0.07692308, 0.1360947, 0.4556213, 0.1005917, 0.2307692), // A141 v 1 144 | (0.07563026, 0.2268908, 0.3781513, 0.07563026, 0.2436975)), // A141 v 2 145 | ((0.01639344, 0.2131148, 0.3770492, 0.1803279, 0.2131148), // A142 v 1 146 | (0.1162791, 0.1162791, 0.3488372, 0.255814, 0.1627907)), // A142 v 2 147 | ((0.01603376, 0.007594936, 0.5274262, 0.08016878, 0.3687764), // A143 v 1 148 | (0.08609272, 0.05960265, 0.6203091, 0.08609272, 0.1479029))); // A143 v 2 ; 149 | }; 150 | 151 | node credit_ammnt { 152 | kind = NATURE; 153 | discrete = TRUE; 154 | chance = CHANCE; 155 | states = (v____inf_9293_224258__, v___9293_224258_inf__); 156 | parents = (duration); 157 | probs = 158 | // v inf 9293 22 v 9293 224258 // duration 159 | ((0.9698795, 0.03012048), // v inf 6 46676 160 | (0.9985715, 0.001428571), // v 6 466767 15 161 | (0.9519427, 0.04805726), // v 15 141068 41 162 | (0.7256098, 0.2743903)); // v 41 487977 in ; 163 | }; 164 | 165 | node installment_rate { 166 | kind = NATURE; 167 | discrete = TRUE; 168 | chance = CHANCE; 169 | states = (v____inf_3_341706__, v___3_341706_inf__); 170 | parents = (duration); 171 | probs = 172 | // v inf 3 34170 v 3 341706 inf // duration 173 | ((0.7530121, 0.246988), // v inf 6 46676 174 | (0.5214286, 0.4785714), // v 6 466767 15 175 | (0.4775051, 0.5224949), // v 15 141068 41 176 | (0.5792683, 0.4207317)); // v 41 487977 in ; 177 | }; 178 | 179 | node job { 180 | kind = NATURE; 181 | discrete = TRUE; 182 | chance = CHANCE; 183 | states = (A171, A172, A173, A174); 184 | parents = (property); 185 | probs = 186 | // A171 A172 A173 A174 // property 187 | ((0.02992958, 0.3503521, 0.568662, 0.05105634), // A121 188 | (0.01495726, 0.215812, 0.6431624, 0.1260684), // A122 189 | (0.01646707, 0.1122755, 0.6991018, 0.1721557), // A123 190 | (0.04166667, 0.09294872, 0.5544872, 0.3108974)); // A124 ; 191 | }; 192 | 193 | node telephone { 194 | kind = NATURE; 195 | discrete = TRUE; 196 | chance = CHANCE; 197 | states = (A191, A192); 198 | parents = (credit_ammnt, job); 199 | probs = 200 | // A191 A192 // credit_ammnt job 201 | (((0.75, 0.25), // v inf 9293 22 A171 202 | (0.8545918, 0.1454082), // v inf 9293 22 A172 203 | (0.6299019, 0.370098), // v inf 9293 22 A173 204 | (0.1535433, 0.8464567)), // v inf 9293 22 A174 205 | ((0.25, 0.75), // v 9293 224258 A171 206 | (0.4166667, 0.5833333), // v 9293 224258 A172 207 | (0.275, 0.725), // v 9293 224258 A173 208 | (0.1086956, 0.8913044))); // v 9293 224258 A174 ; 209 | }; 210 | 211 | node employment { 212 | kind = NATURE; 213 | discrete = TRUE; 214 | chance = CHANCE; 215 | states = (A71, A72, A73, A74, A75); 216 | parents = (job); 217 | probs = 218 | // A71 A72 A73 A74 A75 // job 219 | ((0.6734694, 0.2244898, 0.06122449, 0.02040816, 0.02040816), // A171 220 | (0.007407407, 0.2197531, 0.3975309, 0.1703704, 0.2049383), // A172 221 | (0.01976285, 0.1699605, 0.3644269, 0.1889328, 0.256917), // A173 222 | (0.2225914, 0.1096345, 0.1893688, 0.1428571, 0.3355482)); // A174 ; 223 | }; 224 | 225 | node residence_since { 226 | kind = NATURE; 227 | discrete = TRUE; 228 | chance = CHANCE; 229 | states = (v____inf_1_305453__, v___1_305453_2_338632__, v___2_338632_inf__); 230 | parents = (employment, housing); 231 | probs = 232 | // v inf 1 30545 v 1 305453 2 3 v 2 338632 inf // employment housing 233 | (((0.05263158, 0.368421, 0.5789474), // A71 A151 234 | (0.1604938, 0.308642, 0.5308642), // A71 A152 235 | (0.03030303, 0.2121212, 0.7575758)), // A71 A153 236 | ((0.1958763, 0.1134021, 0.6907216), // A72 A151 237 | (0.3692946, 0.2697096, 0.3609959), // A72 A152 238 | (0.2, 0.2, 0.6)), // A72 A153 239 | ((0.024, 0.36, 0.616), // A73 A151 240 | (0.1203156, 0.5384616, 0.3412229), // A73 A152 241 | (0.05454545, 0.2363636, 0.7090909)), // A73 A153 242 | ((0.01492537, 0.1343284, 0.8507463), // A74 A151 243 | (0.1924528, 0.290566, 0.5169811), // A74 A152 244 | (0.28, 0.04, 0.68)), // A74 A153 245 | ((0.04615385, 0.2, 0.7538462), // A75 A151 246 | (0.05475504, 0.2161383, 0.7291066), // A75 A152 247 | (0.009708738, 0.06796116, 0.9223301))); // A75 A153 ; 248 | }; 249 | 250 | node dependents { 251 | kind = NATURE; 252 | discrete = TRUE; 253 | chance = CHANCE; 254 | states = (v____inf_1_855854__, v___1_855854_inf__); 255 | parents = (personal_status); 256 | probs = 257 | // v inf 1 85585 v 1 855854 inf // personal_status 258 | ((0.9313725, 0.06862745), // A91 259 | (0.9533762, 0.04662379), // A92 260 | (0.7513661, 0.2486339), // A93 261 | (0.9731183, 0.02688172), // A94 262 | (0.5, 0.5)); // A95 ; 263 | }; 264 | 265 | node age { 266 | kind = NATURE; 267 | discrete = TRUE; 268 | chance = CHANCE; 269 | states = (v____inf_45_381878__, v___45_381878_58_133338__, v___58_133338_inf__); 270 | parents = (employment); 271 | probs = 272 | // v inf 45 3818 v 45 381878 58 v 58 133338 in // employment 273 | ((0.6850393, 0.1496063, 0.1653543), // A71 274 | (0.9250721, 0.07204611, 0.002881844), // A72 275 | (0.876652, 0.0866373, 0.03671072), // A73 276 | (0.8917379, 0.07692308, 0.03133903), // A74 277 | (0.6188605, 0.2730845, 0.108055)); // A75 ; 278 | }; 279 | 280 | node purpose { 281 | kind = NATURE; 282 | discrete = TRUE; 283 | chance = CHANCE; 284 | states = (A40, A41, A42, A43, A44, A45, A46, A47, A48, A49, A410); 285 | parents = (); 286 | probs = 287 | // A40 A41 A42 A43 A44 A45 A46 A47 A48 A49 A410 288 | (0.2332173, 0.1029339, 0.1805072, 0.2789657, 0.01243163, 0.02237693, 0.05022377, 4.97265e-4, 0.009448036, 0.09696668, 0.01243163); 289 | }; 290 | 291 | node existing_credits { 292 | kind = NATURE; 293 | discrete = TRUE; 294 | chance = CHANCE; 295 | states = (v____inf_3_17417__, v___3_17417_inf__); 296 | parents = (); 297 | probs = 298 | // v inf 3 17417 v 3 17417 inf 299 | (0.9935065, 0.006493506); 300 | }; 301 | 302 | node foreign_worker { 303 | kind = NATURE; 304 | discrete = TRUE; 305 | chance = CHANCE; 306 | states = (A201, A202); 307 | parents = (); 308 | probs = 309 | // A201 A202 310 | (0.9625375, 0.03746254); 311 | }; 312 | }; 313 | -------------------------------------------------------------------------------- /nets/simple.dne: -------------------------------------------------------------------------------- 1 | // ~->[DNET-1]->~ 2 | 3 | // File created by someone at MonashU using Netica 3.19 on Aug 31, 2007 at 19:01:05. 4 | 5 | bnet simple { 6 | AutoCompile = TRUE; 7 | autoupdate = TRUE; 8 | whenchanged = 1188550832; 9 | 10 | visual V1 { 11 | defdispform = BELIEFBARS; 12 | nodelabeling = TITLE; 13 | NodeMaxNumEntries = 50; 14 | nodefont = font {shape= "Arial"; size= 10;}; 15 | linkfont = font {shape= "Arial"; size= 9;}; 16 | windowposn = (44, 44, 756, 513); 17 | resolution = 72; 18 | drawingbounds = (1044, 769); 19 | showpagebreaks = FALSE; 20 | usegrid = TRUE; 21 | gridspace = (6, 6); 22 | NodeSet Node {BuiltIn = 1; Color = 0xc0c0c0;}; 23 | NodeSet Nature {BuiltIn = 1; Color = 0xf8eed2;}; 24 | NodeSet Deterministic {BuiltIn = 1; Color = 0xd3caa6;}; 25 | NodeSet Finding {BuiltIn = 1; Color = 0xc8c8c8;}; 26 | NodeSet Constant {BuiltIn = 1; Color = 0xffffff;}; 27 | NodeSet ConstantValue {BuiltIn = 1; Color = 0xffffb4;}; 28 | NodeSet Utility {BuiltIn = 1; Color = 0xffbdbd;}; 29 | NodeSet Decision {BuiltIn = 1; Color = 0xdee8ff;}; 30 | NodeSet Documentation {BuiltIn = 1; Color = 0xf0fafa;}; 31 | NodeSet Title {BuiltIn = 1; Color = 0xffffff;}; 32 | PrinterSetting A { 33 | margins = (1270, 1270, 1270, 1270); 34 | landscape = FALSE; 35 | magnify = 1; 36 | }; 37 | }; 38 | 39 | node A { 40 | kind = NATURE; 41 | discrete = TRUE; 42 | chance = CHANCE; 43 | numstates = 2; 44 | parents = (); 45 | probs = 46 | // state0 state1 47 | (0.5, 0.5); 48 | whenchanged = 1188550827; 49 | belief = (0.5, 0.5); 50 | visual V1 { 51 | center = (288, 108); 52 | height = 1; 53 | }; 54 | }; 55 | 56 | node B { 57 | kind = NATURE; 58 | discrete = TRUE; 59 | chance = CHANCE; 60 | numstates = 2; 61 | parents = (A); 62 | probs = 63 | // state0 state1 // A 64 | ((0.8, 0.2), // state0 65 | (0.2, 0.8)); // state1 ; 66 | whenchanged = 1188550832; 67 | belief = (0.5, 0.5); 68 | visual V1 { 69 | center = (138, 270); 70 | height = 3; 71 | }; 72 | }; 73 | 74 | node C { 75 | kind = NATURE; 76 | discrete = TRUE; 77 | chance = CHANCE; 78 | numstates = 2; 79 | parents = (A); 80 | probs = 81 | // state0 state1 // A 82 | ((0.4, 0.6), // state0 83 | (0.6, 0.4)); // state1 ; 84 | whenchanged = 1188550819; 85 | belief = (0.5, 0.5); 86 | visual V1 { 87 | center = (438, 270); 88 | height = 2; 89 | }; 90 | }; 91 | ElimOrder = (B, A, C); 92 | }; 93 | -------------------------------------------------------------------------------- /src/bn-utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; bn-utils - helper macros and functions for Bayesian Network 3 | ;; compilation. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | ;;(declaim (optimize (speed 3))) 27 | 28 | (defmacro multiply-floats (floats) 29 | (let ((gfloats (gensym))) 30 | `(let ((,gfloats ,floats)) 31 | (cond ((endp ,gfloats) 1.0d0) 32 | ((cdr ,gfloats) (reduce #'* ,gfloats)) 33 | ((car ,gfloats)))))) 34 | 35 | (defmacro sum-floats (floats) 36 | (let ((gfloats (gensym))) 37 | `(let ((,gfloats ,floats)) 38 | (cond ((endp ,gfloats) 0.0d0) 39 | ((cdr ,gfloats) (reduce #'+ ,gfloats)) 40 | ((car ,gfloats)))))) 41 | 42 | (defmacro vlength (vec) 43 | `(array-dimension ,vec 0)) 44 | 45 | (defmacro do-upper ((i j len &optional result) &body body) 46 | "do for upper triangular i and j. i from 0 to len, j from i+1 to len." 47 | (let ((glen (gensym))) 48 | `(let ((,glen ,len)) 49 | (dotimes (,i ,glen ,result) 50 | (loop for ,j from (1+ ,i) to (1- ,len) 51 | do ,@body))))) 52 | 53 | (defmacro reset-potential (place) 54 | `(setf ,place (make-vector (length ,place) 1))) 55 | 56 | (defparameter *temporary-directory* "/tmp/" 57 | "Temporary work directory for C-based network compilation") 58 | 59 | (defun random-choose (seq) 60 | (declare (sequence seq)) 61 | (elt seq (random (length seq)))) 62 | 63 | ;; This is not really good. Fix sometime. 64 | (defun find-temporary-file (prefix suffix &optional (directory *temporary-directory*)) 65 | (ensure-directories-exist directory) 66 | (loop 67 | for i fixnum = 0 then (1+ i) 68 | for file = (merge-pathnames (format nil "~A~A~A" prefix i suffix) directory) 69 | unless (probe-file file) do (return file))) 70 | 71 | (defun float-to-fixnums (float) 72 | "This converts a float to a list of fixnums, useful for hashing floats using fixnum-based schemes." 73 | (with-calculation float 74 | (multiple-value-bind (bignum exponent) (integer-decode-float float) 75 | (loop 76 | for fixnum = (logand bignum #.most-positive-fixnum) then 77 | (logand next #.most-positive-fixnum) 78 | for next = (ash bignum #.(- (integer-length most-positive-fixnum))) then 79 | (ash next #.(- (integer-length most-positive-fixnum))) 80 | collect fixnum into fixnums 81 | until (= next 0) 82 | finally (return (cons exponent fixnums)))))) 83 | 84 | (defun split (p x) 85 | (do ((y x z) 86 | (z (cdr x) (cdr z)) 87 | (pt ()) 88 | (pn ())) 89 | ((endp y) 90 | (values pt pn)) 91 | (if (funcall p (car y)) 92 | (setq pt (rplacd y pt)) 93 | (setq pn (rplacd y pn))))) 94 | 95 | (defun degen-prob (i length) 96 | "Creates a 0-vector of the given length, with the i'th argument set to 1." 97 | (let ((vec (make-array length :initial-element 0.0d0))) 98 | (setf (aref vec i) 1.0d0) 99 | vec)) 100 | 101 | (defun map-pairs (fn list) 102 | "applies fn to each pair of items and returns a list of the resulting values. 103 | > (map-pairs #'cons '(1 2 3 4)) 104 | => ((1 . 2) (1 . 3) (1 . 4) (2 . 3) (2 . 4) (3 . 4))" 105 | (mapcon (lambda (x) 106 | (let ((me (car x))) 107 | (mapcar (lambda (you) (funcall fn me you)) (cdr x)))) 108 | list)) 109 | 110 | (defun symmetric (array x y) 111 | "Treat 2D array as a symmetric array. Settable." 112 | (if (< x y) 113 | (aref array x y) 114 | (aref array y x))) 115 | 116 | (defun (setf symmetric) (val array x y) 117 | (if (< x y) 118 | (setf (aref array x y) val) 119 | (setf (aref array y x) val))) 120 | 121 | (defun node-combinations (initial node-mask) 122 | "Returns a vector of all node index combinations built from initial. 123 | node-mask is a vector which is nil for non-incremented nodes and 124 | numstates for included nodes. DEPRECATED for being horribly slow." 125 | (let* ((num-combs (reduce #'* (remove nil node-mask))) 126 | (combs (make-array num-combs)) 127 | (net-state (copy-array initial))) 128 | (dotimes (i (vlength node-mask)) 129 | (when (svref node-mask i) (setf (svref net-state i) 0))) 130 | (setf (svref combs 0) (copy-array net-state)) 131 | (do ((i 1 (1+ i))) 132 | ((= i num-combs) combs) 133 | (cpt-incf net-state node-mask) 134 | (setf (svref combs i) (copy-array net-state))))) 135 | 136 | (defun split-probs (probs prob-length) 137 | (declare (type list probs) 138 | (fixnum prob-length)) 139 | (loop with len = (length probs) 140 | with prob-vec = (make-array (the fixnum (/ len prob-length)) 141 | :element-type 'vector :initial-element #()) 142 | for prob-num = 0 then (1+ prob-num) 143 | while probs 144 | for prob = (make-array prob-length :element-type 'float :initial-element 0.0) 145 | do (dotimes (i prob-length) 146 | (setf (aref prob i) (pop probs))) 147 | (setf (aref prob-vec prob-num) prob) 148 | finally (return prob-vec))) 149 | 150 | (defun edge< (edge1 edge2) 151 | (let ((e1a (car edge1)) (e2a (car edge2))) 152 | (declare (fixnum e1a e2a)) 153 | (or (< e1a e2a) (and (= e1a e2a) 154 | (let ((e1d (cdr edge1)) (e2d (cdr edge2))) 155 | (declare (fixnum e1d e2d)) 156 | (< e1d e2d)))))) 157 | 158 | (defun edge= (edge1 edge2) 159 | (and (= (car edge1) (car edge2)) (= (cdr edge1) (cdr edge2)))) 160 | 161 | (defun vecfn (fn num) 162 | "Build a vector by calling fn num times." 163 | (declare (fixnum num)) 164 | (let ((vec (make-array num))) 165 | (dotimes (i num vec) 166 | (setf (svref vec i) (funcall fn))))) 167 | 168 | 169 | -------------------------------------------------------------------------------- /src/bn.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; bn - Bayesian Network classes, evidence and querying APIs. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | (defgeneric name (net/node) 26 | (:documentation 27 | "For a net, a string identifier and for a node, a keyword 28 | identifier.")) 29 | 30 | (defgeneric net (node/join-tree) 31 | (:documentation 32 | "Returns the containing net for a node or join-tree.")) 33 | 34 | (defgeneric node-order (net) 35 | (:documentation 36 | "Returns a list of node-names as keywords. The ordering matches 37 | their index order. This is set as part of the network compilation 38 | process.")) 39 | 40 | (defgeneric num-nodes (net) 41 | (:documentation 42 | "The amount of nodes in the network.")) 43 | 44 | (defclass net () 45 | ((name :reader name :writer set-name) 46 | (compiled :initform nil :accessor compiled) 47 | (node-order :reader node-order :writer set-node-order); :type (simple-vector)) 48 | ;; for rapid access by index. 49 | (num-nodes :reader num-nodes) 50 | (node-vec :accessor node-vec); :type (simple-array node *)) 51 | (nodes :initform (make-hash-table) :reader nodes) 52 | (properties :initform (make-hash-table) :reader properties))) 53 | 54 | (defgeneric num-states (node) 55 | (:documentation 56 | "The amount of states for the given node.")) 57 | 58 | (defgeneric parents (node) 59 | (:documentation 60 | "A vector of parent names as keywords for the given node.")) 61 | 62 | (defgeneric states (node) 63 | (:documentation 64 | "A vector of state names as keywords for the given node.")) 65 | 66 | (defclass node () 67 | ((name :reader name :writer set-name) 68 | (net :reader net :writer set-net :initarg :net) 69 | (table :accessor table) 70 | (states :reader states :writer set-states) 71 | (parents :reader parents :writer set-parents) 72 | ;; for rapid access by index. 73 | (parent-vec :accessor parent-vec); :type (simple-array node *)) 74 | (parent-indices :accessor parent-indices :type (simple-array fixnum *)) 75 | (num-states :reader num-states) 76 | (index :accessor index) 77 | (evidence :accessor %evidence :initform -1); :type fixnum) 78 | (properties :initform (make-hash-table) :reader properties))) 79 | 80 | (defun statep (node state) 81 | (or (and (integerp state) (>= state 0) (< state (num-states node))) 82 | (position state (states node)))) 83 | 84 | (defun num-states-1 (node) 85 | (length (states node))) 86 | 87 | (defun num-nodes-1 (net) 88 | (hash-table-count (nodes net))) 89 | 90 | (defun preprocess-node (node) 91 | "Store information for efficient lookup." 92 | (with-slots (parents) node 93 | (declare (simple-vector parents)) 94 | (loop with parent-vec = 95 | (make-array (length parents)); :element-type 'node :initial-element node) 96 | with parent-indices = 97 | (make-array (length parents) :element-type 'fixnum :initial-element 0) 98 | for parent-name across parents 99 | for parent = (node parent-name (net node)) 100 | for index = 0 then (1+ index) 101 | do 102 | (setf (aref parent-vec index) parent) 103 | (setf (aref parent-indices index) (index parent)) 104 | finally (setf (slot-value node 'num-states) (length (states node)) 105 | (slot-value node 'parent-vec) parent-vec 106 | (slot-value node 'parent-indices) parent-indices)))) 107 | 108 | (defun preprocess-network (net) 109 | "Readies the network for efficient lookup. 110 | Sets a node ordering for the network. Also sets node parent-vec and 111 | parent-indices." 112 | (loop 113 | with array = (make-array (hash-table-count (nodes net))) 114 | with node-vec = (make-array (length array)); :element-type 'node 115 | ;:initial-element (make-instance 'node)) 116 | for name being each hash-key in (nodes net) 117 | for node being each hash-value in (nodes net) 118 | for index = 0 then (1+ index) 119 | do 120 | (setf (aref array index) name) 121 | (setf (aref node-vec index) node) 122 | (setf (index node) index) 123 | finally 124 | (setf (slot-value net 'num-nodes) (length node-vec)) 125 | (set-node-order array net) 126 | (setf (node-vec net) node-vec) 127 | (loop for node across (node-vec net) ;; now do node parents 128 | do (preprocess-node node)) 129 | (return (node-order net)))) 130 | 131 | (defun num-arcs (net) 132 | (loop 133 | for node being each hash-value in (nodes net) 134 | sum (length (the simple-vector (parents node))))) 135 | 136 | (defgeneric node (name/index net/join-tree) 137 | (:documentation 138 | "Retrieve the node represented by a keyword name or index from the 139 | given net or join-tree.")) 140 | 141 | (defmethod node ((name symbol) (net net)) 142 | (gethash name (nodes net))) 143 | 144 | (defmethod node ((index fixnum) (net net)) 145 | (with-slots (node-vec) net 146 | ;(declare (type (simple-array node *) node-vec)) 147 | (aref node-vec index))) 148 | 149 | (defun table-lookup (table indices) 150 | (apply #'aref table indices)) 151 | 152 | ;; evidence 153 | (defgeneric clear-evidence (object) 154 | (:documentation "Clear all evidence from object.")) 155 | 156 | (defmethod clear-evidence ((node node)) 157 | (setf (%evidence node) -1)) 158 | 159 | (defmethod clear-evidence ((net net)) 160 | (loop 161 | for node being each hash-value in (nodes net) 162 | do (clear-evidence node))) 163 | 164 | (defgeneric evidence-index (object) 165 | (:documentation 166 | "Returns the evidence in a node as a state index and nets as a 167 | vector of state indices. -1 indicates no evidence.")) 168 | 169 | (defmethod evidence-index ((node node)) 170 | (%evidence node)) 171 | 172 | (defmethod evidence-index ((net net)) 173 | (loop 174 | for node being each hash-value in (nodes net) 175 | for evidence = (evidence-index node) 176 | when evidence nconc (list (name node) evidence))) 177 | 178 | (defgeneric evidence (object) 179 | (:documentation 180 | "Returns the evidence in a node as its state symbol (nil if no 181 | evidence), and for nets and join-trees a plist of node-state 182 | pairs. Settable.")) 183 | 184 | (defmethod evidence ((node node)) 185 | (let ((evidence (%evidence node))) 186 | (declare (fixnum evidence)) 187 | (unless (< evidence 0) 188 | (svref (states node) evidence)))) 189 | 190 | (defmethod evidence ((net net)) 191 | (loop 192 | for node being each hash-value in (nodes net) 193 | for evidence = (evidence node) 194 | when evidence nconc (list (name node) evidence))) 195 | 196 | (defgeneric add-evidence (object evidence) 197 | (:documentation 198 | "Sets the evidence in a node via state index or symbol. For a net 199 | or join-tree, adds the evidence as a plist of node-state pairs.")) 200 | 201 | (defmethod add-evidence ((net net) (evidence list)) 202 | (when evidence 203 | (destructuring-bind (name state &rest next) evidence 204 | (setf (evidence (or (node name net) 205 | (error "add-evidence: Could not find node ~A in net!" name))) 206 | state) 207 | (add-evidence net next))) 208 | evidence) 209 | 210 | (defmethod add-evidence (object evidence) 211 | (setf (evidence object) evidence)) 212 | 213 | (defgeneric (setf evidence) (evidence object) 214 | (:documentation 215 | "Sets the evidence in a node via state index or symbol. For a net 216 | or join-tree, sets the evidence as either a plist of node-state pairs, 217 | or a vector of state indices (or -1 for unobserved) corresponding to 218 | the net's node-order.")) 219 | 220 | (defmethod (setf evidence) ((null null) (node node)) 221 | (setf (%evidence node) -1)) 222 | 223 | (defmethod (setf evidence) ((index integer) (node node)) 224 | (setf (%evidence node) index)) 225 | 226 | (defmethod (setf evidence) ((state symbol) (node node)) 227 | (setf (%evidence node) (position state (states node))) 228 | state) 229 | 230 | (defmethod (setf evidence) ((evidence list) (net net)) 231 | (clear-evidence net) 232 | (add-evidence net evidence)) 233 | 234 | (defmethod (setf evidence) ((evidence vector) (net net)) 235 | "Sets net's evidence according to net-state vec." 236 | (loop 237 | for name across (node-order net) 238 | for ev across evidence 239 | for node = (node name net) 240 | do (setf (evidence node) ev))) 241 | 242 | (defun %evidence-1 (net array) 243 | ;(declare (type (array (array fixnum *)))) 244 | (let ((nodes (node-order net))) 245 | (dotimes (i (vlength nodes) array) 246 | (setf (aref array i) (evidence-index (node (aref nodes i) net)))))) 247 | 248 | (defgeneric evidence-1 (object)) 249 | 250 | (defmethod evidence-1 ((net net)) 251 | (%evidence-1 net (make-array (num-nodes net)))); :element-type 'fixnum))) 252 | 253 | (defmacro save-evidence (object &body body) 254 | (with-gensyms (gobject gstore) 255 | `(let* ((,gobject ,object) 256 | (,gstore (evidence-1 ,gobject))) 257 | (unwind-protect (progn ,@body) 258 | (setf (evidence ,gobject) ,gstore))))) 259 | 260 | (defmacro with-evidence ((net &rest evidence) &body body) 261 | "Saves the existing evidence in the net and sets the evidence to 262 | evidence. Restores the net to its previous state after leaving the 263 | with-evidence block." 264 | (let ((gnet (gensym))) 265 | `(let ((,gnet ,net)) 266 | (save-evidence ,gnet 267 | (setf (evidence ,gnet) ',evidence) 268 | ,@body)))) 269 | 270 | (defgeneric %query (net query) 271 | (:documentation "Query a net/node.")) 272 | 273 | (defmethod %query ((node node) (query integer)) 274 | (when (and (>= query 0) (< query (num-states node))) 275 | (let ((old (evidence-index node))) 276 | (unwind-protect (/ (progn (setf (evidence node) query) 277 | (%query (net node) nil)) 278 | (progn (setf (evidence node) nil) 279 | (%query (net node) nil))) 280 | (setf (evidence node) old))))) 281 | 282 | (defmethod %query ((node node) (query symbol)) 283 | (awhen (position query (states node)) 284 | (%query node it))) 285 | 286 | (defmethod %query ((node node) (query null)) 287 | (let ((old (evidence-index node))) 288 | (unwind-protect 289 | (let ((probs (make-array (num-states node))); :element-type 'double-float)) 290 | (total 0.0d0)) 291 | (dotimes (i (num-states node)) 292 | (let ((val (progn (setf (evidence node) i) 293 | (%query (net node) nil)))) 294 | (incf total val) 295 | (setf (aref probs i) val))) 296 | (dotimes (i (num-states node) probs) 297 | (setf (aref probs i) (/ (aref probs i) total)))) 298 | (setf (evidence node) old)))) 299 | 300 | (defmethod %query ((node node) (query list)) 301 | (let ((old (evidence-index node))) 302 | (unwind-protect 303 | (let ((probs (make-array (num-states node))); :element-type 'double-float)) 304 | (total 0.0d0)) 305 | (dotimes (i (num-states node)) 306 | (let ((val (%query (net node) (list* (name node) i query)))) 307 | (incf total val) 308 | (setf (aref probs i) val))) 309 | (dotimes (i (num-states node) probs) 310 | (setf (aref probs i) (/ (aref probs i) total)))) 311 | (setf (evidence node) old)))) 312 | 313 | 314 | (defmethod %query ((net net) (query vector)) 315 | (funcall (compiled net) query)) 316 | 317 | (defmethod %query ((net net) (query symbol)) 318 | (awhen (node query net) 319 | (%query it nil))) 320 | 321 | 322 | (defmethod %query ((net net) (query list)) 323 | (with-evidence (net) 324 | (add-evidence net query) 325 | (%query net nil))) 326 | 327 | (defmethod %query ((net net) (query null)) 328 | (funcall (compiled net) (evidence-1 net))) 329 | 330 | (defun query (object &optional query) 331 | "Queries a net or node object. 332 | 333 | node only - A probability vector for the states of node. 334 | 335 | node and integer - The probability the node is in that numbered state 336 | (according to (states node)). 337 | 338 | node and symbol - The probability the node is in that state. 339 | 340 | node and list - A probability vector for the states of node given 341 | list, which is a plist of node-state pairs. 342 | 343 | net only - The joint probability for the whole net. 344 | 345 | net and vector - The joint probability for the whole net, given the 346 | vector. Vector has the num-nodes length, and 347 | contains either a state number for each node, or -1 348 | if the node state is unknown. 349 | 350 | net and symbol - A probability vector for the states of the node 351 | designated by symbol. 352 | 353 | net and list - The joint probability for the whole net, given list, 354 | which is a plist of node-state pairs. 355 | " 356 | (%query object query)) 357 | 358 | (defun gen-parameter (net net-state node-num) 359 | "Generate a parameter for the net with the given net-state and node-num." 360 | (declare (optimize (speed 3) (safety 0)) 361 | (type (mod #.most-positive-fixnum) node-num)) 362 | (loop with node = (node node-num net) 363 | and state = (aref net-state node-num) 364 | for parent-index across (the (simple-array fixnum *) (parent-indices node)) 365 | ;; collect the state for this parent. 366 | collect (svref net-state parent-index) 367 | into dims 368 | finally (return (coerce (svref (apply #'aref (table node) dims) state) 369 | 'double-float)))) 370 | -------------------------------------------------------------------------------- /src/clique-tree.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; clique-tree - tools for clique-trees, which are intermediate 3 | ;; structures for building join-trees. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | (defun neighbours (graph node-num) 27 | "Generates a list of neighbours of the node." 28 | (aref graph node-num)) 29 | 30 | (defun neighbour (graph a b) 31 | (find b (aref graph a))) 32 | 33 | (defun connect (graph a b) 34 | (pushnew a (aref graph b) :test #'=) 35 | (pushnew b (aref graph a) :test #'=)) 36 | 37 | (defun floyd-warshall (graph) 38 | "This finds all shortest paths in graph. I could make it more 39 | efficient by using the fact that the paths are symmetric." 40 | ;; Assume a function edgeCost(i,j) which returns the cost of the edge from i to j 41 | ;; (infinity if there is none). 42 | ;; Also assume that n is the number of vertices and edgeCost(i,i)=0 43 | (let ((n (length graph))) 44 | (flet ((edge-cost (i j) 45 | (cond ((= i j) 0) 46 | ((neighbour graph i j) 1) 47 | (t n)))) 48 | ;; int path[][] - A 2-Dimensional matrix. At each step in the 49 | ;; algorithm, path[i][j] is the shortest path from i to j using 50 | ;; intermediate values in (1..k-1). Each path[i][j] is 51 | ;; initialized to edgeCost(i,j). 52 | (let ((path (make-array `(,n ,n) :element-type 'fixnum :initial-element 0))) 53 | (dotimes (i n) 54 | (dotimes (j n) (setf (aref path i j) (edge-cost i j)))) 55 | ;; procedure FloydWarshall () 56 | (dotimes (k n path) 57 | (dotimes (i n) 58 | (dotimes (j n) 59 | (unless (or (= i j) (= i k) (= j k)) 60 | (setf (aref path i j) 61 | (min (aref path i j) 62 | (+ (aref path i k) (aref path k j)))))))))))) 63 | 64 | (defun moral (net) 65 | (loop with moral = (make-array (length (node-order net)) :initial-element nil) 66 | for i from 0 to (1- (length moral)) 67 | for node across (node-vec net) 68 | do 69 | (loop for par across (parent-indices node) 70 | do (connect moral i par) 71 | (loop for par2 across (parent-indices node) 72 | do (unless (= par par2) ; inefficient 73 | (connect moral par par2)))) 74 | finally (return moral))) 75 | 76 | (defun cluster-node (graph node) 77 | "Generates a list of added links (node1 . node2) which are necessary 78 | to form a cluster around node. Uses an (edge-tree)." 79 | (let (cluster) 80 | (map-pairs (lambda (a b) 81 | (unless (neighbour graph a b) 82 | (pushnew (if (< a b) (cons a b) (cons b a)) cluster))) 83 | (aref graph node)) 84 | cluster)) 85 | 86 | (defun weight-cluster (net graph node) 87 | "a cluster's weight is the product of its nodes' states." 88 | (let ((val (num-states (node node net)))) 89 | (dolist (neighbour (aref graph node) val) 90 | (setf val (* val (num-states (node neighbour net))))))) 91 | 92 | (defun delete-node (graph node) 93 | "Remove references to the node from graph. Replaces the node with t" 94 | (dolist (neighbour (aref graph node)) 95 | (setf (aref graph neighbour) (delete node (aref graph neighbour)))) 96 | (setf (aref graph node) nil)) 97 | 98 | (defun gen-cliques (net graph) 99 | "Graph is an array of (itree), where each tree contains that node's neighbours. 100 | Returns a list of cliques obtained from triangulating the graph. The 101 | triangulation can be recovered by starting with a moral graph and 102 | ensuring each clique is completely connected. Each clique is an itree 103 | of nodes. Destroys graph." 104 | (let ((candidates (map-int #'identity (length graph))) 105 | cliques) 106 | (flet ((clique< (node1 node2) 107 | (let ((cluster1 (cluster-node graph node1)) 108 | (cluster2 (cluster-node graph node2))) 109 | (or (< (length cluster1) (length cluster2)) 110 | (and (= (length cluster1) (length cluster2)) 111 | (< (weight-cluster net graph node1) 112 | (weight-cluster net graph node2))))))) 113 | (while candidates 114 | (setf candidates (sort candidates #'clique<)) 115 | (let* ((best (pop candidates)) 116 | (clique (copy-list (aref graph best)))) 117 | (push best clique) 118 | (unless (member-if (lambda (x) (subsetp clique x)) 119 | cliques) 120 | (push clique cliques)) 121 | (dolist (edge (cluster-node graph best)) 122 | (connect graph (car edge) (cdr edge))) 123 | (delete-node graph best))) 124 | (setf cliques (coerce (nreverse cliques) 'vector)) 125 | (dotimes (i (length cliques) cliques) ;; sort the cliques. 126 | (setf (aref cliques i) (sort (aref cliques i) #'<)))))) 127 | 128 | (defun sep-mass (a b) 129 | "Find |intersection| of lists clique1 and clique2" 130 | (length (intersection a b))) 131 | 132 | (defun sep-cost (a b states) 133 | "Find prod states of x in X + prod states of y in Y. clique1 134 | and clique2 are lists, states is a vector." 135 | (+ (reduce #'* a :key (lambda (x) (aref states x))) 136 | (reduce #'* b :key (lambda (x) (aref states x))))) 137 | 138 | (defun sep-sets (cliques states) 139 | (sort (map-pairs #'cons (map-int #'identity (length cliques))) 140 | (lambda (x y) 141 | (let ((x-mass (sep-mass (aref cliques (car x)) (aref cliques (cdr x)))) 142 | (y-mass (sep-mass (aref cliques (car y)) (aref cliques (cdr y))))) 143 | (cond ((> x-mass y-mass)) 144 | ((= x-mass y-mass) ;; below is still slow. Could cache. 145 | (< (sep-cost (aref cliques (car x)) 146 | (aref cliques (cdr x)) states) 147 | (sep-cost (aref cliques (car y)) 148 | (aref cliques (cdr y)) states)))))))) 149 | 150 | (defun path (graph a b) 151 | (labels ((%path (graph a b path) 152 | (when (member b (aref graph a) :test #'=) (return-from path path)) 153 | (dolist (next (aref graph a)) 154 | (when (not (member next path :test #'=)) 155 | (awhen (%path graph next b (cons next path)) 156 | (return-from path it)))))) 157 | (%path graph a b (list a)))) 158 | 159 | (defun cycle (graph a) 160 | (labels ((%path (graph a b path) 161 | (when (member b (aref graph a) :test #'=) (return-from %path path)) 162 | (dolist (next (aref graph a)) 163 | (when (not (member next path :test #'=)) 164 | (awhen (%path graph next b (cons next path)) 165 | (return-from %path it)))))) 166 | (dolist (next (aref graph a)) 167 | (dolist (next-next (aref graph next)) 168 | (unless (= next-next a) 169 | (%path graph next-next a (list next-next next a))))))) 170 | 171 | (defun roots (graph) 172 | "Returns the roots of the graph as a list." 173 | (loop with roots = (list 0) 174 | for i from 1 to (1- (length graph)) 175 | do (unless (dolist (root roots) ;; unless i is connected to a root... 176 | (when (path graph root i) (return t))) 177 | (push i roots)) 178 | finally (return roots))) 179 | 180 | (defun clique-tree (net) 181 | "Builds a clique-tree for dag. The tree is represented by an 182 | upper triangular matrix which has lists of clique-nodes in its 183 | diagonal." 184 | (let* ((cliques (gen-cliques net (moral net))) 185 | (len (length cliques)) 186 | (states (returnit (make-array (num-nodes net)); :element-type 'fixnum) 187 | (dotimes (i (num-nodes net)) 188 | (setf (aref it i) (num-states (node i net)))))) 189 | (tree (make-array len :initial-element nil)) 190 | (sep-sets (sep-sets cliques states)) 191 | (edge-number 0)) 192 | (while (and (< edge-number len) sep-sets) 193 | (let ((sep-set (pop sep-sets))) 194 | (unless (path tree (car sep-set) (cdr sep-set)) 195 | (connect tree (car sep-set) (cdr sep-set)) 196 | (incf edge-number)))) 197 | (values cliques tree))) 198 | 199 | (defun assign-nodes (net cliques) 200 | "Returns an assignment of a clique node for each net node. Since 201 | lookup within a clique is sequential, just uses an array of lists. An 202 | array of assignments from the node perspective is returned as a second 203 | value." 204 | (loop 205 | with assignment = 206 | (make-array (length cliques) :initial-element nil) 207 | with node-assignment = 208 | (make-array (num-nodes net) :initial-element 0) 209 | for node-num = 0 then (1+ node-num) 210 | for node across (node-vec net) 211 | for family = (cons node-num (coerce (parent-indices node) 'list)) 212 | do (dotimes (clique (vlength cliques) (error "Node ~A is unassigned!" node-num)) 213 | (when (subsetp family (aref cliques clique)) 214 | (setf (aref node-assignment node-num) clique) 215 | (push node-num (aref assignment clique)) 216 | (return))) 217 | finally (return (values assignment node-assignment)))) 218 | 219 | (defun traverse (tree &optional (root 0)) 220 | "Builds a traversal for the undirected tree structure tree. Structure is 221 | ;(tree-node subtraversal1 ... subtraversaln)" 222 | (labels 223 | ((trav (node visited) 224 | (cons node 225 | (let (trav) 226 | (dotimes (next-node (length tree) trav) 227 | (when (and (neighbour tree node next-node) ;; they are connected 228 | ;; and a node in the separator has not been assigned 229 | (not (member next-node visited :test #'=))) 230 | (push (trav next-node (cons node visited)) trav))))))) 231 | (trav root nil))) 232 | 233 | (defun tree-depth (tree root) 234 | (loop with closed = (returnit (make-hash-table :test 'eql) 235 | (setf (gethash root it) t)) 236 | with open = (aref tree root) with len = (length tree) 237 | for depth from 0 for new-open = nil 238 | until (= (hash-table-count closed) len) do 239 | (dolist (node open) 240 | (setf (gethash node closed) t)) 241 | (dolist (node open) 242 | (dolist (new-node (aref tree node)) ;; this works because it's a tree. 243 | (unless (gethash new-node closed) 244 | (push new-node new-open)))) 245 | (setf open new-open) 246 | finally (return depth))) 247 | 248 | (defun best-root (tree) 249 | (let ((list (map-int (lambda (x) (tree-depth tree x)) (length tree)))) 250 | (multiple-value-bind (val pos) (best list #'<) 251 | (declare (ignore val)) 252 | pos))) 253 | 254 | (defun net-masks (net cliques traversal) 255 | "Shadowing traversal, returns (tree-node node-mask combinations) for 256 | each tree-node in traversal." 257 | (with-slots (node-vec) net 258 | (labels ((net-mask (net-state clique) 259 | (loop with combinations = 1 260 | with net-mask = (make-array (num-nodes net) :initial-element nil) 261 | for node-state across net-state 262 | for node-num = 0 then (1+ node-num) 263 | do 264 | (when (and (null node-state) 265 | (member node-num clique)) 266 | (let ((num-states (num-states (aref node-vec node-num)))) 267 | (setf (aref net-mask node-num) num-states) 268 | (setf combinations (* combinations num-states)))) 269 | finally (return (values net-mask combinations)))) 270 | (traverse (traversal net-state) 271 | (multiple-value-bind (net-mask combs) 272 | (net-mask net-state (svref cliques (car traversal))) 273 | (dotimes (i (length net-mask)) ;; set net-state as per net-mask 274 | (when (aref net-mask i) (setf (aref net-state i) t))) 275 | (prog1 (cons (list (car traversal) net-mask combs) 276 | (loop for trav in (cdr traversal) 277 | collect (traverse trav net-state))) 278 | (dotimes (i (length net-mask)) ;; unset net-state. 279 | (when (aref net-mask i) (setf (aref net-state i) nil))))))) 280 | (traverse traversal (make-array (num-nodes net) :initial-element nil))))) 281 | -------------------------------------------------------------------------------- /src/compiler.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; compiler - compile a Bayesian Network to a set of Arithmetic 3 | ;; Circuit instructions. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | ;; this is the class that the net gets compiled to. 27 | (defclass instructions () 28 | ((forms :initform nil 29 | :accessor forms :type list) 30 | ;; lookups are defined in initialize-instance 31 | (match-lookup :reader match-lookup) 32 | (+-lookup :reader +-lookup) 33 | (*-lookup :reader *-lookup) 34 | (form-count :initform 0 :accessor form-count :type fixnum) 35 | (assignment :accessor assignment :type (simple-array fixnum *)) 36 | (cliques :accessor cliques :type simple-vector) 37 | (tree :accessor tree :type simple-vector))) 38 | 39 | (defmethod initialize-instance :after ((ins instructions) &key net) 40 | (when net 41 | (with-slots (cliques tree assignment match-lookup +-lookup *-lookup) ins 42 | (multiple-value-setq (cliques tree) (clique-tree net)) 43 | (setf assignment (assign-nodes net cliques)) 44 | (setf match-lookup 45 | (make-array (num-nodes net) :element-type '(simple-array fixnum))) 46 | (dotimes (i (num-nodes net)) 47 | (setf (aref match-lookup i) 48 | (make-array (num-states (aref (node-vec net) i)) 49 | :element-type 'fixnum :initial-element -1))) 50 | (setf +-lookup (vecfn #'make-trie (1+ (length cliques)))) 51 | (setf *-lookup (vecfn #'make-trie (1+ (length cliques))))))) 52 | 53 | (defun set-match (ins node-num value form-num) 54 | ;; (declare (type (mod 536870912) node-num value form-num) (optimize (speed 3) (safety 0))) 55 | (let ((match-lookup (match-lookup ins))) 56 | (declare (type (simple-array (simple-array fixnum *) *) match-lookup)) 57 | (setf (aref (aref match-lookup node-num) value) form-num))) 58 | 59 | (defun get-match (ins node-num value) 60 | ;; (declare (type (mod 536870912) node-num value) (optimize (speed 3) (safety 0))) 61 | (let ((match-lookup (match-lookup ins))) 62 | (declare (type (simple-array (simple-array fixnum *) *) match-lookup)) 63 | (aref (aref match-lookup node-num) value))) 64 | 65 | (defun set-+ (ins vals form-num depth) 66 | ;; (declare (optimize (speed 3) (safety 0))) 67 | (let ((first (car vals))) 68 | (trie-insert form-num (aref (+-lookup ins) depth) 69 | (if (floatp first) 70 | (append (float-to-fixnums first) (cdr vals)) 71 | vals)))) 72 | 73 | (defun get-+ (ins vals depth) 74 | ;; (declare (optimize (speed 3) (safety 0))) 75 | (let ((first (car vals))) 76 | (awhen (trie-search (aref (+-lookup ins) depth) 77 | (if (floatp first) 78 | (append (float-to-fixnums first) (cdr vals)) 79 | vals)) 80 | (trie-value it)))) 81 | 82 | (defun set-* (ins vals form-num depth) 83 | ;; (declare (optimize (speed 3) (safety 0))) 84 | (let ((first (car vals))) 85 | (trie-insert form-num (aref (*-lookup ins) depth) 86 | (if (floatp first) 87 | (append (float-to-fixnums first) (cdr vals)) 88 | vals)))) 89 | 90 | (defun get-* (ins vals depth) 91 | ;; (declare (optimize (speed 3) (safety 0))) 92 | (let ((first (car vals))) 93 | (awhen (trie-search (aref (*-lookup ins) depth) 94 | (if (floatp first) 95 | (append (float-to-fixnums first) (cdr vals)) 96 | vals)) 97 | (trie-value it)))) 98 | 99 | (defun add-form (form ins &optional depth) 100 | (let ((form-num (form-count ins)) 101 | (op (car form))) 102 | (cond ((numberp op) (set-match ins op (cdr form) form-num)) 103 | ((eq op '*) (set-* ins (cdr form) form-num depth)) 104 | ((eq op '+) (set-+ ins (cdr form) form-num depth))) 105 | (push form (forms ins)); form-num) 106 | (incf (form-count ins)) 107 | form-num)) 108 | 109 | (defun push-form (form ins &optional depth) 110 | "Pushes a form onto instructions, and returns an index into forms. 111 | Won't actually add a form if a matching one exists (acts like pushnew)." 112 | (let ((op (car form))) 113 | (cond ((numberp op) (let ((form-num (get-match ins op (cdr form)))) 114 | (if (>= form-num 0) form-num 115 | (add-form form ins)))) 116 | ((eq op '*) (or (get-* ins (cdr form) depth) (add-form form ins depth))) 117 | ((eq op '+) (or (get-+ ins (cdr form) depth) (add-form form ins depth)))))) 118 | 119 | (defun gen-evidence (net net-state node-num) 120 | (declare (ignore net)) 121 | (cons node-num (svref net-state node-num))) 122 | 123 | (defun post-process-times (depth args ins) 124 | "Puts the form in canonical form for insertion." 125 | (multiple-value-bind (floats indices) 126 | (split #'floatp args) 127 | (let ((total (multiply-floats floats))) 128 | (cond ((endp indices) total) ; no indices 129 | ((endp (cdr indices)) ; one new index 130 | (if (= total 1.0d0) ; and no num 131 | (car indices) ; delegate 132 | (push-form `(* ,total ,(car indices)) ins depth))) ; else push total and index 133 | (t (let ((sorted (sort indices #'<))) ; sort multiple indices 134 | (if (= total 1.0d0) (push-form (cons '* sorted) ins depth) ; no total, just push the form. 135 | ;; make a new index for sorted and push the result. 136 | (push-form (list* '* total sorted) ins depth)))))))) 137 | 138 | (defun post-process-plus (depth args ins) 139 | "Puts the form in canonical form for insertion." 140 | (multiple-value-bind (floats indices) 141 | (split #'floatp args) 142 | (let ((total (sum-floats floats))) 143 | (cond ((endp indices) total) ; no indices 144 | ((endp (cdr indices)) ; one new index 145 | (if (= total 0.0d0) ; and no num 146 | (car indices) ; delegate 147 | (push-form `(+ ,total ,(car indices)) ins depth))) ; else push total and index 148 | (t (let ((sorted (sort indices #'<))) ; sort multiple indices 149 | (if (= total 0.0d0) (push-form (cons '+ sorted) ins depth) ; no total, just push the form. 150 | ;; make a new index for sorted and push the result. 151 | (push-form (list* '+ total sorted) ins depth)))))))) 152 | 153 | (defun gen-separator (net ins net-state traversal depth) 154 | "bn - a net object. 155 | clique-tree - a clique-tree built from the bn's dag. Symmetric array 156 | with node-num lists on the diagonal and t where connected. 157 | node-assignment - (aref node-assignment node-num) == node's clique index. 158 | net-state - array of the current node states. Nil means the node hasn't 159 | been processed. 160 | traversal - the current traversal to operate on: (clique trav1 ... travn) 161 | depth - the current depth of the traversal." 162 | (post-process-plus 163 | depth 164 | ;; generate a multiply for each net-state instantiation. 165 | (destructuring-bind (clique-num net-mask combs) (car traversal) 166 | (declare (ignore clique-num)) 167 | (dotimes (i (length net-mask)) 168 | (when (aref net-mask i) (setf (aref net-state i) 0))) 169 | (loop repeat combs ;; iterate through the node assigment 170 | collect (gen-clique net ins net-state traversal depth) 171 | do (cpt-incf net-state net-mask) 172 | finally 173 | (dotimes (i (vlength net-mask)) 174 | (when (aref net-mask i) (setf (aref net-state i) nil))))) 175 | ins)) 176 | 177 | (defun gen-clique (net ins net-state traversal depth) 178 | (flet ((check-zero (x) (if (and (floatp x) (= 0.0d0 (the double-float x))) 179 | (return-from gen-clique 0.0d0) 180 | x))) 181 | (with-slots (assignment) ins 182 | (post-process-times depth 183 | ;; multiplies floats and sorts indices. Also pushes onto forms. 184 | (let (this-form) 185 | ;; assigned node parameters and evidence indicators. 186 | (loop for node-num in (aref assignment (caar traversal)) do 187 | (push (push-form (gen-evidence net net-state node-num) ins) this-form) 188 | (push (check-zero (gen-parameter net net-state node-num)) this-form)) 189 | ;; children (connected cliques which haven't yet been assigned) 190 | (dolist (trav (cdr traversal) this-form) 191 | (push (check-zero (gen-separator net ins net-state trav (1+ depth))) this-form))) 192 | ins)))) 193 | 194 | (defun best-traversal (net ins) 195 | (with-slots (tree cliques) ins 196 | (labels ((trav-third (trav) 197 | (cons (funcall #'third (car trav)) 198 | (mapcar #'trav-third (cdr trav)))) 199 | (gen-trav (node) 200 | (net-masks net cliques (traverse tree node))) 201 | (traversal-max-mult (trav) 202 | (* (car trav) 203 | (reduce #'max (mapcar #'traversal-max-mult (cdr trav)) 204 | :initial-value 1)))) 205 | (let ((travs (map-int #'gen-trav (length tree)))) 206 | (best travs #'< :key (compose #'traversal-max-mult #'trav-third)))))) 207 | 208 | (defun gen-instructions (net) 209 | "Generate an arithmetic circuit for the bn represented by a 210 | net (bn.lisp). Note that this version assumes the clique-tree is a 211 | single tree (which is correct at 15/12/2007)." 212 | (unless (slot-boundp net 'node-order) (preprocess-network net)) 213 | (with-calculation-context (eql) 214 | (let ((ins (make-instance 'instructions :net net)) 215 | (net-state (make-array (num-nodes net) :initial-element nil))) 216 | (gen-separator net ins net-state (best-traversal net ins) 0) 217 | (setf (forms ins) (nreverse (forms ins))) 218 | ins))) 219 | 220 | (defun match (val1 val2) 221 | (declare (type fixnum val1 val2)) 222 | "Matches evidence." 223 | (the double-float 224 | (if (< val1 0) 1.0d0 (if (= val1 val2) 1.0d0 0.0d0)))) 225 | (declaim (ftype (function (fixnum fixnum) double-float) match) 226 | (inline match)) 227 | 228 | (defun interpret (ins net-spec) 229 | (loop with results = (make-array (form-count ins)); :element-type 'double-float) 230 | for i fixnum from 0 231 | for (inst-type . vals) in (forms ins) do 232 | (setf (aref results i) 233 | (cond ((numberp inst-type) 234 | (match (aref net-spec inst-type) vals)) 235 | ((eq inst-type '+) 236 | (loop with val1 = (car vals) 237 | with retval = (if (floatp val1) val1 (aref results val1)) 238 | for val in (cdr vals) 239 | do (incf retval (aref results val)) 240 | finally (return retval))) 241 | ((eq inst-type '*) 242 | (loop with val1 = (car vals) 243 | with retval = (if (floatp val1) val1 (aref results val1)) 244 | for val in (cdr vals) 245 | do (when (= retval 0.0d0) (return 0.0d0)) 246 | (setf retval (* retval (aref results val))) 247 | finally (return retval))))) 248 | finally (return (aref results (1- (vlength results)))))) 249 | 250 | (defun use-interpreted (net) 251 | "Use interpreted arithmetic circuit instructions for the 252 | net. Returns the instructions object." 253 | (let ((ins (gen-instructions net))) 254 | (setf (compiled net) 255 | (lambda (net-spec) 256 | (interpret ins net-spec))) 257 | ins)) 258 | -------------------------------------------------------------------------------- /src/emit-c.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; emit-c - Write out C source code from Arithmetic Circuit 3 | ;; instructions, compile and load the resultant shared object. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | (defun emit-c-double (double) 27 | (let ((str (princ-to-string double))) 28 | (nsubstitute #\E #\d str))) 29 | 30 | (defun emit-c-forms (func-name net-spec forms stream) 31 | (loop 32 | for inst in forms 33 | for var = 0 then (1+ var) 34 | for rhs = (if (numberp (car inst)) 35 | (format nil "~Am(~A[~A], ~A)" 36 | func-name net-spec (car inst) (cdr inst)) 37 | (let ((op-string (format nil " ~A " (car inst)))) 38 | (with-output-to-string (s) 39 | (loop for cons on (cdr inst) 40 | do (let ((val (car cons))) 41 | (princ (if (floatp val) (emit-c-double val) 42 | (format nil "v~A" val)) s)) 43 | when (cdr cons) do (princ op-string s))))) 44 | do 45 | (format stream "double v~A = ~A;~%" var rhs))) 46 | 47 | 48 | (defun emit-c-preamble (func-name net-spec stream) 49 | "Write out the matching function for state and val. Returns 1.0 if 50 | state is negative (missing) or state = val. Returns 0.0 otherwise." 51 | (format stream "double ~Am(int state, int val) {~%" func-name) 52 | (format stream " if(state < 0) { return 1.0; }~%") 53 | (format stream " return (state == val) ? 1.0 : 0.0;~%") 54 | (format stream "}~%~%double ~A(int* ~A) {~%" func-name net-spec)) 55 | 56 | (defun emit-c-net (net stream) 57 | (let ((ins (gen-instructions net)) 58 | (func-name (gentemp "__BN"))) 59 | (with-slots (forms form-count) ins 60 | (emit-c-preamble func-name 'NETSPEC stream) 61 | (emit-c-forms func-name 'NETSPEC forms stream) 62 | (format stream "return v~A;~%}~%" (1- form-count)) 63 | (values func-name form-count)))) 64 | 65 | #-cl-bayesnet-no-cffi 66 | (defparameter *gcc-format-string* "gcc -O2 -shared ~A -o ~A" 67 | "String to pass to format. First arg is source, second is target.") 68 | 69 | #-cl-bayesnet-no-cffi 70 | (defun use-compiled-c (net &optional source-location) 71 | "Writes out arithmetic circuit instructions to a c file, compiles it 72 | with gcc, loads the shared object, and prepares the net to use the 73 | loaded function. If source-location is specified, writes the c file 74 | there. Otherwise uses a temporary file. 75 | 76 | Returns the closure used, the raw cffi function pointer, and the 77 | number of instructions." 78 | ;; TODO: c-spec ends up a dangling pointer. 79 | (let ((source (or source-location (find-temporary-file "" ".c"))) 80 | (target (find-temporary-file "" ".so"))) 81 | (multiple-value-bind (func-name form-count) 82 | (with-open-file (s source :direction :output :if-exists :supersede) 83 | (emit-c-net net s)) 84 | (trivial-shell:shell-command (format nil *gcc-format-string* source target)) 85 | (unless source-location (delete-file source)) 86 | (cffi:load-foreign-library target) 87 | (let* ((len (num-nodes net)) 88 | (c-spec (cffi:foreign-alloc :int :count len)) 89 | (func-pointer (cffi:foreign-symbol-pointer (princ-to-string func-name)))) 90 | (values 91 | (setf (compiled net) 92 | (lambda (net-spec) 93 | (dotimes (i len) (setf (cffi:mem-aref c-spec :int i) 94 | (aref net-spec i))) 95 | (cffi:foreign-funcall-pointer func-pointer nil :pointer c-spec :double))) 96 | func-pointer form-count))))) 97 | ;;(foreign-free c-spec) 98 | -------------------------------------------------------------------------------- /src/evidence.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; evidence - implementation of the evidence API for join-tree 3 | ;; objects. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | ;;primitives 27 | ;;(defun make-join-tree (net) 28 | ;;(defun jt-propagate (jt) 29 | ;;(defun jt-prob (jt node-num) 30 | ;;(defun jt-retract (jt) 31 | ;;(defun jt-obs (jt node-num obs) 32 | 33 | (defmethod node ((name symbol) (jt join-tree)) 34 | (find name (nodes jt) :key #'name)) 35 | 36 | (defmethod node ((index fixnum) (jt join-tree)) 37 | (aref (nodes jt) index)) 38 | 39 | (defmethod clear-evidence ((jt join-tree)) 40 | (jt-retract jt)) 41 | 42 | (defmethod evidence-index ((jt join-tree)) 43 | (evidence-1 jt)) 44 | 45 | (defmethod evidence-index ((node jt-node)) 46 | (obs node)) 47 | 48 | (defmethod evidence-1 ((jt join-tree)) 49 | (map 'vector #'obs (nodes jt))) 50 | 51 | (defmethod evidence ((jt join-tree)) 52 | (with-slots (nodes) jt 53 | (loop 54 | for node across nodes 55 | for obs = (obs node) 56 | when (>= obs 0) nconc (list (name node) (aref (states node) obs))))) 57 | 58 | (defmethod evidence ((node jt-node)) 59 | (with-slots (obs states) node 60 | (when (>= obs 0) 61 | (aref states obs)))) 62 | 63 | (defmethod add-evidence ((jt join-tree) (evidence list)) 64 | (with-slots (nodes) jt 65 | (loop for (name state) on evidence by #'cddr 66 | for node-num = (if (numberp name) name 67 | (position name nodes :key #'name)) 68 | for state-num = (if (numberp state) state 69 | (position state (states (aref nodes node-num)))) 70 | do (jt-obs jt node-num state-num)))) 71 | 72 | (defmethod (setf evidence) ((evidence list) (jt join-tree)) 73 | (clear-evidence jt) 74 | (add-evidence jt evidence)) 75 | 76 | (defmethod (setf evidence) ((evidence vector) (jt join-tree)) 77 | "Sets net's evidence according to net-state vec." 78 | (clear-evidence jt) 79 | (loop 80 | for i = 0 then (1+ i) 81 | for ev across evidence 82 | do (when (>= ev 0) (jt-obs jt i ev)))) 83 | 84 | (defmethod (setf evidence) ((state-num integer) (node jt-node)) 85 | (with-slots (join-tree index) node 86 | (jt-obs join-tree index state-num) 87 | state-num)) 88 | 89 | (defmethod (setf evidence) ((state symbol) (node jt-node)) 90 | (setf (evidence node) (position state (states node)))) 91 | 92 | (defmethod %query ((jt join-tree) (query fixnum)) 93 | (jt-propagate jt) 94 | (normalize (jt-prob jt query))) 95 | 96 | (defmethod %query ((jt join-tree) (query symbol)) 97 | (%query jt (position query (nodes jt) :key #'name))) 98 | 99 | (defmethod %query ((jt join-tree) (query null)) 100 | (loop for node across (nodes jt) 101 | for obs = (obs node) 102 | do (when (>= obs 0) 103 | (jt-propagate jt) 104 | (return (aref (jt-prob jt (index node)) obs))) 105 | finally (return 1))) 106 | 107 | (defmethod %query ((jt join-tree) (query vector)) 108 | (save-evidence jt 109 | (setf (evidence jt) query) 110 | (%query jt nil))) 111 | 112 | (defmethod %query ((jt join-tree) (query list)) 113 | "FIXME: should return a single prob for the joint distribution." 114 | (with-slots (nodes) jt 115 | (loop with evidence = (make-array (length nodes) :initial-element -1) 116 | for (name state) on query by #'cddr 117 | for node-num = (if (numberp name) name 118 | (position name nodes :key #'name)) 119 | for state-num = (if (numberp state) state 120 | (position state (states (aref nodes node-num)))) 121 | do (setf (aref evidence node-num) state-num) 122 | finally (return (%query jt evidence))))) 123 | 124 | (defmethod %query ((node jt-node) (query integer)) 125 | (with-slots (index join-tree states) node 126 | (when (and (>= query 0) (< query (length states))) 127 | (aref (%query join-tree index) query)))) 128 | 129 | (defmethod %query ((node jt-node) (query symbol)) 130 | (awhen (position query (states node)) 131 | (%query node it))) 132 | 133 | (defmethod %query ((node jt-node) (query null)) 134 | (with-slots (index join-tree) node 135 | (%query join-tree index))) 136 | 137 | 138 | (defmethod %query ((node jt-node) (query vector)) 139 | (with-slots (index join-tree) node 140 | (save-evidence join-tree 141 | (setf (evidence join-tree) query) 142 | (%query join-tree index)))) 143 | 144 | (defmethod %query ((node jt-node) (query list)) 145 | "FIXME: should return a single prob for the joint distribution." 146 | (with-slots (join-tree) node 147 | (with-slots (nodes) join-tree 148 | (loop with evidence = (make-array (length nodes) :initial-element -1) 149 | for (name state) on query by #'cddr 150 | for node-num = (if (numberp name) name 151 | (position name nodes :key #'name)) 152 | for state-num = (if (numberp state) state 153 | (position state (states (aref nodes node-num)))) 154 | do (setf (aref evidence node-num) state-num) 155 | finally (return (%query node evidence)))))) 156 | 157 | (defun use-join-tree (net) 158 | "Use a join-tree to evaluate this net. Returns the join-tree object." 159 | (let ((jt (make-join-tree net))) 160 | (setf (compiled net) 161 | (lambda (net-spec) 162 | (%query jt net-spec))) 163 | jt)) 164 | -------------------------------------------------------------------------------- /src/message.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; message - join-tree and message passing implementation. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | ;; LH 2013-04-01: I don't know what these are anymore. :( 26 | ;; TODO mv gen-parameter into bn. 27 | ;; - message pass should work better with indices, so we don't have to use find. 28 | ;; - we naively get probs and enter likelihoods in the "default" 29 | ;; cluster. Better to use the cluster with smallest potential. 30 | ;; - Cache probabilities. 31 | ;; - When generating a probability, generate and cache other assigned 32 | ;; probabilities for that cluster, so we don't have to loop 33 | 34 | (defclass potential-container () 35 | ((mask :reader mask :initarg :mask) 36 | (potential :accessor potential :initarg :potential))) 37 | 38 | (defclass cluster (potential-container) 39 | ((mark :accessor mark :initform nil) 40 | (clean-potential :initarg :clean-potential :reader clean-potential))) 41 | 42 | (defclass sep-set (potential-container) ()) 43 | 44 | (defclass join-tree () 45 | ((net :initarg :net :reader net) 46 | (nodes :initarg :nodes :reader nodes) 47 | (clusters :initarg :clusters :reader clusters) 48 | (links :initarg :links :reader links) 49 | (all-sep-sets :initarg :sep-sets :reader all-sep-sets) 50 | (consistent :initform nil :accessor consistent) 51 | (assignment :initarg :assignment :reader assignment) 52 | (obs :initarg :obs :accessor obs) 53 | (evidence :initarg :evidence :reader evi))) 54 | 55 | (defclass jt-node () 56 | ((index :initarg :index :reader index) 57 | (assignment :initarg :assignment :reader assignment) 58 | (evidence :initarg :evidence :accessor evi) 59 | (obs :initarg :obs :accessor obs) 60 | (name :initarg :name :reader name) 61 | (states :initarg :states :reader states) 62 | (join-tree :initarg :join-tree :accessor join-tree-of))) 63 | 64 | (defun make-potential (net cluster assignment) 65 | (loop with mask = (returnit (make-array (num-nodes net) :initial-element nil) 66 | (map nil (lambda (node) 67 | (setf (aref it node) (num-states (node node net)))) 68 | cluster)) 69 | with state = (make-array (length mask) :initial-element 0) 70 | for probs = (mapcar (lambda (x) (gen-parameter net state x)) assignment) 71 | repeat (reduce #'* cluster :key (lambda (x) (num-states (node x net)))) 72 | collect (reduce #'* probs) into potential 73 | do 74 | (cpt-incf state mask) 75 | finally (return (values (coerce potential 'vector) mask)))) 76 | 77 | (defun make-join-tree (net) 78 | (unless (slot-boundp net 'node-order) (preprocess-network net)) 79 | (multiple-value-bind (cliques tree) (clique-tree net) 80 | (multiple-value-bind (assignment node-assignment) (assign-nodes net cliques) 81 | (let ((clusters ;; generate the clusters. 82 | (make-array (length cliques) 83 | :initial-contents (loop for clique across cliques for clique-assign across assignment 84 | collect (multiple-value-bind (potential mask) 85 | (make-potential net clique clique-assign) 86 | (make-instance 'cluster :mask mask :clean-potential potential :potential (copy-seq potential))))))) 87 | ;; Add tree information. Links contains sets of cluster-num-sep-set pairs. 88 | (loop with sep-sets with links = (make-array (length cliques) :initial-element nil) 89 | for link across tree 90 | for clique across cliques 91 | for cluster across clusters 92 | for counter from 0 93 | do 94 | (setf (aref links counter) 95 | (loop for link-num in link collect 96 | (cons link-num (if (> link-num counter) ;; make the separator 97 | (multiple-value-bind (potential mask) 98 | (make-potential net (intersection clique (aref cliques link-num)) nil) 99 | (returnit (make-instance 'sep-set :mask mask :potential potential) 100 | (push it sep-sets))) 101 | ;; else find the existing separator and use that. 102 | (cdr (find counter (aref links link-num) :key #'car)))))) 103 | finally 104 | (let ((nodes (loop for assign across node-assignment 105 | for index from 0 106 | for node = (node index net) 107 | collect (make-instance 'jt-node 108 | :index index 109 | :assignment assign 110 | :evidence (make-array (num-states node) 111 | :initial-element 1) 112 | :obs -1 113 | :name (name node) 114 | :states (states node))))) 115 | (return (returnit (make-instance 'join-tree :clusters clusters :links links 116 | :sep-sets sep-sets ;; :net net 117 | :nodes (coerce nodes 'vector) 118 | :assignment node-assignment) 119 | (loop for node across (nodes it) 120 | do (setf (join-tree-of node) it)))))))))) 121 | 122 | (defun marginalise (sep-set cluster) 123 | "Return a new potential for sep-set to match cluster." 124 | (with-slots (mask potential) cluster 125 | (loop with sep-mask = (mask sep-set) 126 | with sep-pot = (make-array (length (potential sep-set)) 127 | :initial-element 0) 128 | with state = (make-array (length mask) 129 | :initial-element 0) 130 | repeat (length potential) 131 | do (incf (aref sep-pot (cpt-index sep-mask state)) 132 | (aref potential (cpt-index mask state))) 133 | (cpt-incf state mask) 134 | finally (return sep-pot)))) 135 | 136 | (defgeneric message-pass (jt clique1 clique2)) 137 | 138 | (defmethod message-pass ((jt join-tree) (clique1 fixnum) (clique2 fixnum)) 139 | (with-slots (clusters links) jt 140 | (with-slots (mask potential) (aref clusters clique2) 141 | (loop 142 | with sep-set = (cdr (find clique2 (aref links clique1) 143 | :key #'car)) 144 | with sep-mask = (mask sep-set) 145 | with old = (potential sep-set) 146 | with new = (marginalise sep-set (aref clusters clique1)) 147 | with state = (make-array (length mask) 148 | :initial-element 0) 149 | for c-index = (cpt-index mask state) 150 | for s-index = (cpt-index sep-mask state) 151 | repeat (length potential) 152 | do 153 | (multf (aref potential c-index) 154 | (if (= 0 (aref new s-index)) 0 155 | (/ (aref new s-index) 156 | (aref old s-index)))) 157 | (cpt-incf state mask) 158 | finally (return (setf (potential sep-set) new)))))) 159 | 160 | (defun collect-evidence (jt cluster) 161 | (with-slots (clusters links) jt 162 | (setf (mark (aref clusters cluster)) t) 163 | (loop for (cluster2 . nil) in (aref links cluster) 164 | do (unless (mark (aref clusters cluster2)) 165 | (collect-evidence jt cluster2) 166 | (message-pass jt cluster2 cluster))) 167 | )) 168 | 169 | (defun distribute-evidence (jt cluster) 170 | (with-slots (clusters links) jt 171 | (setf (mark (aref clusters cluster)) t) 172 | (loop for (cluster2 . nil) in (aref links cluster) 173 | do (unless (mark (aref clusters cluster2)) 174 | (message-pass jt cluster cluster2) 175 | (distribute-evidence jt cluster2))))) 176 | 177 | (defun jt-propagate (jt) 178 | (with-slots (consistent clusters) jt 179 | (when consistent (return-from jt-propagate)) 180 | (loop for cluster across clusters 181 | do (setf (mark cluster) nil)) 182 | (collect-evidence jt 0) 183 | (loop for cluster across clusters 184 | do (setf (mark cluster) nil)) 185 | (distribute-evidence jt 0) 186 | (setf consistent t))) 187 | 188 | (defun jt-prob (jt node-num) 189 | "Calculates the probability of node-num given junction tree jt." 190 | (let ((cluster (aref (clusters jt) (aref (assignment jt) node-num)))) 191 | (with-slots (mask potential) cluster 192 | (loop 193 | with node-prob = (make-array (aref mask node-num) :initial-element 0) 194 | with node-mask = (returnit (make-array (length mask) :initial-element nil) 195 | (setf (aref it node-num) (aref mask node-num))) 196 | with state = (make-array (length mask) :initial-element 0) 197 | repeat (length potential) 198 | do (incf (aref node-prob (cpt-index node-mask state)) 199 | (aref potential (cpt-index mask state))) 200 | (cpt-incf state mask) 201 | finally (return node-prob))))) 202 | 203 | (defun jt-retract (jt) 204 | (with-slots (consistent clusters all-sep-sets nodes) jt 205 | (when (every (lambda (x) (= -1 (obs x))) nodes) (return-from jt-retract)) 206 | (setf consistent nil) 207 | (loop for cluster across clusters 208 | do (setf (potential cluster) (copy-seq (clean-potential cluster)))) 209 | (loop for sep-set in all-sep-sets 210 | do (reset-potential (potential sep-set))) 211 | (loop for node across nodes 212 | do (with-slots (obs evidence) node 213 | (setf obs -1) 214 | (reset-potential evidence))))) 215 | 216 | (defun jt-obs (jt node-num obs) 217 | "Enter the observation that node-num is obs." 218 | (let ((cluster (aref (clusters jt) (aref (assignment jt) node-num)))) 219 | (with-slots (mask potential) cluster 220 | (when (= obs (obs (aref (nodes jt) node-num))) (return-from jt-obs)) 221 | (setf (consistent jt) nil) 222 | (loop 223 | with likelihood = (returnit (make-array (aref mask node-num) :initial-element 0) 224 | (setf (aref it obs) 1)) 225 | with node-mask = (returnit (make-array (length mask) :initial-element nil) 226 | (setf (aref it node-num) (aref mask node-num))) 227 | with state = (make-array (length mask) :initial-element 0) 228 | repeat (length potential) 229 | for c-index = (cpt-index mask state) 230 | do (multf (aref potential c-index) 231 | (aref likelihood (cpt-index node-mask state))) 232 | (cpt-incf state mask) 233 | finally 234 | (setf (obs (aref (nodes jt) node-num)) obs) 235 | (setf (evi (aref (nodes jt) node-num)) likelihood))))) 236 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; packages - Package and external API definition. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-user) 24 | 25 | (defpackage :cl-bayesnet 26 | (:documentation "A Common Lisp Bayesian Network Inference Engine") 27 | (:use :cl) 28 | (:nicknames :bn) 29 | (:export 30 | ;; create 31 | :load-xmlbif 32 | :load-ace 33 | :load-dne 34 | ;; prepare 35 | :use-compiled-c ;; slow compile, fastest execution. 36 | :use-interpreted ;; slow compile, fast execution. 37 | :use-join-tree ;; fast compile, slow execution. 38 | ;; classes 39 | :net 40 | :node ;; also a reader function. 41 | :join-tree 42 | :instructions 43 | ;; readers 44 | :node-order 45 | :name 46 | :states 47 | :parents 48 | :num-states 49 | :num-nodes 50 | ;; probability querying. 51 | :query 52 | ;; evidence 53 | :clear-evidence 54 | :evidence-index 55 | :evidence 56 | :add-evidence 57 | :with-evidence 58 | )) 59 | 60 | -------------------------------------------------------------------------------- /src/parse-network.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; parse-network - Reading external Bayesian Network files. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | (defun keyify (string) 26 | (intern (string-upcase string) :keyword)) 27 | 28 | (defun dimension-list (list) 29 | "Calculates the dimensionality of the list. EG: 30 | (make-array (dimension-list list) :initial-contents list)))" 31 | (loop 32 | for this = list then (car this) 33 | while (and (listp this) (not (endp this))) 34 | collect (length this))) 35 | 36 | (defun dimension-list-but-one (list) 37 | "Calculates the dimensionality of the list, minus one. EG: 38 | (make-array (dimension-list list) :initial-contents list)))" 39 | (loop 40 | for this = list then (car this) 41 | while (and (listp (car this)) (not (endp (car this)))) 42 | collect (length this))) 43 | 44 | (defun parse-netica-stream (stream &key (net (make-instance 'net))) 45 | "Idea taken from trivial-configuration-parser by Brian Mastenbrook." 46 | (let ((*readtable* (copy-readtable *readtable*)) 47 | (*package* (find-package :keyword)) 48 | (*read-eval* nil) 49 | (*read-base* 10) 50 | (*read-default-float-format* 'double-float) 51 | (*read-suppress* nil)) 52 | (setf (readtable-case *readtable*) :upcase) 53 | ; comments are "//" 54 | (make-dispatch-macro-character #\/) 55 | (let ((fun (get-macro-character #\;))) 56 | (set-dispatch-macro-character #\/ #\/ 57 | (lambda (s c1 c2) 58 | (declare (ignore c2)) 59 | (funcall fun s c1)))) 60 | ;;(set-syntax-from-char #\# #\;) 61 | (set-syntax-from-char #\; #\ ) 62 | (set-syntax-from-char #\, #\Space) 63 | (set-macro-character #\{ 64 | (lambda (stream char) 65 | (declare (ignore char)) 66 | (read-delimited-list #\} stream t))) 67 | (set-macro-character #\} 68 | (lambda (stream char) 69 | (declare (ignore stream char)) 70 | (error "Unmatched close brace!"))) 71 | (set-syntax-from-char #\: #\ ) 72 | (let* ((eof-value (gensym "EOF")) 73 | (read-file (loop for thing = (read stream nil eof-value) 74 | while (not (eql thing eof-value)) 75 | collect thing))) 76 | (parse-netica-net read-file :net net)))) 77 | 78 | (defun parse-netica-net (list &key (net (make-instance 'net))) 79 | (let ((first (first list)) 80 | (name (second list)) 81 | (defs (third list))) 82 | (assert (eql first :bnet)) 83 | (setf (slot-value net 'name) (symbol-name name)) 84 | (do* ((first (pop defs) (pop defs)) 85 | (second (pop defs) (pop defs)) 86 | (third (pop defs) (pop defs))) 87 | ((null first) net) 88 | (cond ((eql :node first) 89 | (setf (gethash second (slot-value net 'nodes)) 90 | (returnit (parse-netica-node second third) 91 | (set-net net it) net))) 92 | ((eql second :=) 93 | (setf (gethash first (slot-value net 'properties)) third)) 94 | (t (format t "Couldn't parse triple ~A, ~A, ~A, ignoring." 95 | first second third)))))) 96 | 97 | (defun parse-netica-node (name list) 98 | (let ((node (make-instance 'node))) 99 | (setf (slot-value node 'name) name) 100 | (do* ((first (pop list) (pop list)) 101 | (second (pop list) (pop list)) 102 | (third (pop list) (pop list))) 103 | ((null first) node) 104 | (if (eql second :=) 105 | (case first 106 | (:probs 107 | (setf (slot-value node 'table) 108 | (maparray (lambda (x) (coerce x 'vector)) 109 | (make-array (dimension-list-but-one third) 110 | :initial-contents third)))) 111 | (:functable 112 | (awhen (states node) 113 | (setf (slot-value node 'table) 114 | (maparray (lambda (x) 115 | (degen-prob (position x it) 116 | (length it))) 117 | (make-array (dimension-list third) 118 | :initial-contents third))))) 119 | (:numstates 120 | (setf (slot-value node 'states) (returnit (make-array third) 121 | (dotimes (i third) 122 | (setf (aref it i) i))))) 123 | (:states 124 | (setf (slot-value node 'states) (coerce third 'vector))) 125 | (:parents 126 | (setf (slot-value node 'parents) (coerce third 'vector))) 127 | (otherwise 128 | (setf (gethash first (slot-value node 'properties)) third))) 129 | (format t "Couldn't parse triple ~A, ~A, ~A, ignoring." 130 | first second third))))) 131 | 132 | (defun load-dne (file) 133 | "Load a file in Netica's dne file format. Returns a net." 134 | (with-open-file (s file :direction :input) 135 | (parse-netica-stream s))) 136 | 137 | ;;; ace ;;; 138 | (defun parse-ace-stream (stream &key (net (make-instance 'net))) 139 | "Idea taken from trivial-configuration-parser by Brian Mastenbrook." 140 | (let ((*readtable* (copy-readtable *readtable*)) 141 | (*package* (find-package :keyword)) 142 | (*read-eval* nil) 143 | (*read-base* 10) 144 | (*read-default-float-format* 'double-float) 145 | (*read-suppress* nil)) 146 | (setf (readtable-case *readtable*) :upcase) 147 | ; comments are "//" 148 | (make-dispatch-macro-character #\/) 149 | (let ((fun (get-macro-character #\;))) 150 | (set-dispatch-macro-character #\/ #\/ 151 | (lambda (s c1 c2) 152 | (declare (ignore c2)) 153 | (funcall fun s c1)))) 154 | ;;(set-syntax-from-char #\# #\;) 155 | (set-syntax-from-char #\| #\Space) 156 | (set-syntax-from-char #\; #\Space) 157 | (set-syntax-from-char #\, #\Space) 158 | (set-macro-character #\{ 159 | (lambda (stream char) 160 | (declare (ignore char)) 161 | (read-delimited-list #\} stream t))) 162 | (set-macro-character #\} 163 | (lambda (stream char) 164 | (declare (ignore stream char)) 165 | (error "Unmatched close brace!"))) 166 | (set-syntax-from-char #\: #\ ) 167 | (loop 168 | with eof-value = (gensym "EOF") 169 | with ignore = 0 170 | for thing = (read stream nil eof-value) 171 | while (not (eql thing eof-value)) 172 | if (> ignore 0) do (decf ignore) 173 | else do 174 | (case thing 175 | (:net (setf ignore 1)) 176 | (:node 177 | (let ((name (read stream nil eof-value)) 178 | (list (read stream nil eof-value))) 179 | (setf (gethash name (slot-value net 'nodes)) 180 | (returnit (parse-netica-node name list) 181 | (set-net net it) net)))) 182 | (:potential 183 | (let ((parents (read stream nil eof-value)) 184 | (data-list (read stream nil eof-value))) 185 | (parse-ace-potential net parents data-list)))) 186 | finally (return net)))) 187 | 188 | (defun parse-ace-potential (net parents data-list) 189 | (let* ((node (node (pop parents) net)) 190 | (num-states (num-states-1 node)) 191 | (probs (third data-list))) 192 | (declare (list probs) (fixnum num-states)) 193 | (setf (slot-value node 'parents) (coerce parents 'vector)) 194 | (setf (slot-value node 'table) 195 | (cond ((some #'consp probs) 196 | (maparray (lambda (x) (coerce x 'vector)) 197 | (make-array (the list (dimension-list-but-one probs)) 198 | :initial-contents probs))) 199 | ((> (length probs) num-states) 200 | (make-array (mapcar (lambda (x) (num-states-1 (node x net))) parents) 201 | :displaced-to (split-probs probs num-states))) 202 | (t 203 | (make-array nil 204 | :initial-element 205 | (make-array num-states :element-type 'float 206 | :initial-contents probs))))))) 207 | 208 | (defun parse-ace-node (name list) 209 | (let ((node (make-instance 'node))) 210 | (setf (slot-value node 'name) name) 211 | (do* ((first (pop list) (pop list)) 212 | (second (pop list) (pop list)) 213 | (third (pop list) (pop list))) 214 | ((null first) node) 215 | (if (eql second :=) 216 | (case first 217 | (:states 218 | (setf (slot-value node 'states) 219 | (map 'vector #'keyify third))) 220 | (otherwise 221 | (setf (gethash first (slot-value node 'properties)) third))) 222 | (format t "Couldn't parse triple ~A, ~A, ~A, ignoring." 223 | first second third))))) 224 | 225 | (defun load-ace (file) 226 | "Load a file in ace file format. Returns a net." 227 | (with-open-file (s file :direction :input) 228 | (parse-ace-stream s))) 229 | 230 | (defun load-xmlbif (file) 231 | "Load a file in xmlbif file format. Returns a net." 232 | (let ((net (make-instance 'net)) 233 | (lxml-net (cdr (assoc :network (s-xml:parse-xml-file file :output-type :lxml))))) 234 | (dolist (node lxml-net) 235 | (let ((node-name (if (listp (car node)) (caar node) (car node)))) 236 | (case node-name 237 | (:name 238 | (set-name (second node) net)) 239 | (:variable 240 | (xmlbif-add-variable net node)) 241 | (:definition 242 | (xmlbif-add-definition net node)) 243 | (t (warn "load-xmlbif-file: Ignoring node ~S" node))))) 244 | net)) 245 | 246 | (defun xmlbif-add-variable (net node) 247 | ;; could check for node TYPE = "nature" here. 248 | (loop with bnode = (make-instance 'node) 249 | with outcomes 250 | for (key value) in (cdr node) do 251 | (case key 252 | (:name (set-name (keyify value) bnode)) 253 | (:outcome (push (keyify value) outcomes)) 254 | (t (warn "xmlbif-add-variable: ignoring ~A=~A" key value))) 255 | finally 256 | (assert (name bnode) () "xmlbif-add-variable: variable does not have a name!") 257 | (set-states (coerce (nreverse outcomes) 'simple-vector) bnode) 258 | (setf (gethash (name bnode) (nodes net)) bnode) 259 | (set-net net bnode) 260 | (return bnode))) 261 | 262 | (defun xmlbif-add-definition (net def) 263 | ;; could check for node TYPE = "nature" here. 264 | (loop with node with parents with probs 265 | for (key value) in (cdr def) do 266 | (case key 267 | (:for (setf node (or (gethash (keyify value) (nodes net)) 268 | (error "xmlbif-add-definition: could not find node for definition ~A" def)))) 269 | (:given (push (keyify value) parents)) ;; reverse order. 270 | (:table (setf probs (with-input-from-string (in value) 271 | (loop with *read-eval* = nil 272 | for float = (read in nil nil) 273 | while float collect float))))) 274 | finally 275 | (setf parents (nreverse parents)) 276 | (set-parents (coerce parents 'simple-vector) node) 277 | ;; this isn't the most efficient table representation. But remember this gets compiled later. 278 | (loop with state-count = (length (states node)) 279 | with table-arity = (loop for parent in parents collect (length (states (gethash parent (nodes net))))) 280 | with flat-table = (make-array (reduce #'* table-arity :initial-value 1)) ;; initial-value handles table-arity = nil. 281 | for index from 0 282 | for probs1 on probs by (lambda (x) (nthcdr state-count x)) do 283 | (setf (aref flat-table index) (coerce (subseq probs1 0 state-count) 'simple-vector)) 284 | finally (setf (table node) (make-array table-arity :displaced-to flat-table))))) 285 | 286 | (defmethod initialize-instance :after ((net net) &key netica-file ace-file bif-file) 287 | (cond (netica-file (load-netica-file netica-file :net net)) 288 | (ace-file (load-ace-file ace-file :net net)) 289 | (bif-file (load-xmlbif-file bif-file :net net)))) 290 | 291 | -------------------------------------------------------------------------------- /src/test.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; test - Internal test tools to make random networks and evidence. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | (defun random-graph (num-nodes num-arcs &key ensure-connected) 26 | (declare (fixnum num-nodes num-arcs)) 27 | ;; make graph 28 | (let ((graph (make-array num-nodes :initial-element nil))) 29 | (when (> num-arcs 0) 30 | (loop with i = 0 31 | for a = (random num-nodes) 32 | for b = (random num-nodes) 33 | do (unless (or (= a b) (neighbour graph a b)) 34 | (connect graph a b) (incf i)) 35 | until (= i num-arcs))) 36 | (when ensure-connected 37 | (loop for roots = (roots graph) 38 | while (cdr roots) 39 | for shuffle = (shuffle (length roots)) 40 | do (connect graph (nth (aref shuffle 0) roots) 41 | (nth (aref shuffle 1) roots)))) 42 | graph)) 43 | 44 | (defun random-prob (num-states) 45 | (declare (fixnum num-states)) 46 | (loop with prob = (make-array num-states :element-type 'float :initial-element 0.0) 47 | with total = 0.0d0 48 | for i from 0 to (1- num-states) 49 | do (incf total (setf (aref prob i) (random 1.0))) 50 | finally 51 | (dotimes (j num-states) (setf (aref prob j) (/ (aref prob j) total))) 52 | (return prob))) 53 | 54 | (defun random-table (node) 55 | (loop 56 | with net = (net node) 57 | with parent-states = 58 | (map 'list (lambda (x) (num-states-1 (node x net))) (parents node)) 59 | with combs = (reduce #'* parent-states) 60 | with num-states = (num-states-1 node) 61 | with prob-vec = (make-array combs) 62 | for i from 0 to (1- combs) 63 | do (setf (aref prob-vec i) (random-prob num-states)) 64 | finally (return (make-array parent-states 65 | :displaced-to prob-vec)))) 66 | 67 | (defun random-network (max-states &rest random-graph-args) 68 | ;; make net 69 | (loop with graph = (apply #'random-graph random-graph-args) 70 | with net = (make-instance 'net) 71 | with total-order = (shuffle (length graph)) 72 | for i of-type fixnum across total-order 73 | for node = (make-instance 'node :net net) 74 | do 75 | (setf (slot-value node 'name) (intern (format nil "V~A" i) :keyword)) 76 | (setf (slot-value node 'parents) 77 | (map 'vector (lambda (x) (intern (format nil "V~A" x) :keyword)) 78 | (aref graph i))) 79 | (setf (slot-value node 'states) 80 | (coerce (let ((min (if (consp max-states) (first max-states) 2)) 81 | (max (if (consp max-states) (second max-states) 82 | max-states))) 83 | (map-int #'identity (+ min (random (1+ (- max min)))))) 84 | 'vector)) 85 | (setf (gethash (name node) (nodes net)) node) 86 | (delete-node graph i) 87 | finally 88 | (loop 89 | for node being each hash-value in (nodes net) 90 | do (setf (table node) (random-table node))) 91 | (return net))) 92 | 93 | (defun net-graph (net) 94 | "Output the net's structure in a viewable form." 95 | (coerce 96 | (loop for i from 0 to (1- (num-nodes net)) 97 | collect (coerce (parent-indices (node i net)) 'list)) 98 | 'vector)) 99 | 100 | (defun test-net-random (net &optional (iterations 100)) 101 | (assert (compiled net) () "Choose a compilation type for the net.") 102 | (let (probs 103 | (net-spec (make-array (num-nodes net) 104 | :element-type 'fixnum)) 105 | (array (returnit (make-array (num-nodes net)) 106 | (dotimes (i (num-nodes net)) 107 | (setf (aref it i) i))))) 108 | (dotimes (i iterations probs) 109 | (push (%query net (random-evidence net net-spec array)) probs)))) 110 | 111 | (defun random-evidence (net &optional 112 | (net-spec (make-array (num-nodes net) 113 | :element-type 'fixnum)) 114 | (arr (returnit (make-array (num-nodes net) 115 | :element-type 'fixnum) 116 | (dotimes (i (num-nodes net)) 117 | (setf (aref it i) i))))) 118 | (shuffle arr) 119 | (dotimes (i (vlength net-spec)) (setf (aref net-spec i) -1)) 120 | (dotimes (j (random (num-nodes net))) 121 | (setf (aref net-spec (aref arr j)) 122 | (random (num-states (node (aref arr j) net))))) 123 | net-spec) 124 | 125 | (defun junction-p (cliques tree) 126 | "Test whether the tree is in fact a junction tree, meaning for each 127 | pair of cliques, all cliques in between contain their intersection." 128 | (dotimes (i (1- (length cliques)) t) 129 | (loop for j from (1+ i) to (1- (length cliques)) 130 | for intersection = (intersection (aref cliques i) (aref cliques j)) 131 | do (loop for clique-num in (path tree i j) ;; inefficiently checks node j. 132 | for clique = (aref cliques clique-num) 133 | do (dolist (node intersection) 134 | (unless (member node clique) 135 | (return-from junction-p nil))))))) 136 | -------------------------------------------------------------------------------- /src/tries.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; tries - trie implementation for compiling Arithmetic Circuits. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | (defconstant +TRIE-HASH-THRESHOLD+ 7) 26 | 27 | (defstruct TRIE 28 | "A trie node." 29 | (value nil) 30 | (count 0) ;; only incremented when branch is a list. 31 | (test 'eql) 32 | (branch nil)) 33 | 34 | (defun TRIE-CLEAR (trie) 35 | "Empties the trie, but leaves the test as is." 36 | (setf (trie-value trie) nil 37 | (trie-count trie) 0 38 | (trie-branch trie) nil) 39 | trie) 40 | 41 | (defun MAKE-TRIE-HASH (alist &key (test 'eql)) 42 | "Converts a trie alist to a trie-specific hash." 43 | (let ((hash (make-hash-table :test test))) 44 | (dolist (element alist hash) 45 | (setf (gethash (car element) hash) (cdr element))))) 46 | 47 | (defun TRIE-BRANCH-COUNT (trie) 48 | "Count the number of branches of trie." 49 | (if (typep (trie-branch trie) 'hash-table) 50 | (hash-table-count (trie-branch trie)) 51 | (trie-count trie))) 52 | 53 | (defun TRIE-SEARCH (trie key) 54 | "Recursively search the trie for the given key. If key is nil, 55 | We're at the right node, so we return it. The value (which may be 56 | nil) can then be accessed with trie-value." 57 | (etypecase key 58 | (null trie) 59 | (list (let ((branch (trie-branch trie))) 60 | (cond ((null branch) nil) 61 | ((listp branch) (awhen (assoc (car key) branch :test (trie-test trie)) 62 | (trie-search (cdr it) (cdr key)))) 63 | (t (awhen (gethash (car key) branch) 64 | (trie-search it (cdr key))))))) 65 | (sequence (trie-search trie (coerce key 'list))))) 66 | 67 | (defun TRIE-INSERT (value trie key) 68 | "Insert the value in the trie with the given key. Returns the 69 | accessed trie node." 70 | (etypecase key 71 | (null (progn (setf (trie-value trie) value) trie)) 72 | (list (symbol-macrolet ((count (trie-count trie)) 73 | (branch (trie-branch trie)) 74 | (test (trie-test trie))) 75 | (declare (type fixnum count)) 76 | (if (listp branch) 77 | (aif (assoc (car key) branch :test test) 78 | (trie-insert value (cdr it) (cdr key)) 79 | (let ((new-trie (make-trie :test test))) 80 | (push (cons (car key) new-trie) branch) 81 | (incf count) 82 | (when (= (the fixnum count) (the fixnum +trie-hash-threshold+)) 83 | (setf branch (make-trie-hash branch :test test))) 84 | (trie-insert value new-trie (cdr key)))) 85 | (aif (gethash (car key) branch) 86 | (trie-insert value it (cdr key)) 87 | (let ((new-trie (make-trie :test test))) 88 | (setf (gethash (car key) branch) new-trie) 89 | (trie-insert value new-trie (cdr key))))))) 90 | (sequence (trie-insert value trie (coerce key 'list))))) 91 | 92 | (defun TRIE-PRUNE (to-prune example) 93 | "Recursively remove all branches in to-prune that don't also appear 94 | in example, thus to-prune is guaranteed to be as small as example or 95 | smaller." 96 | (symbol-macrolet ((branch (trie-branch to-prune))) 97 | (if (listp branch) 98 | (setf branch 99 | (loop for cons in branch 100 | for next-example = (trie-search example `(,(car cons))) 101 | when next-example 102 | collect cons 103 | and do (trie-prune (cdr cons) next-example)) 104 | (trie-count to-prune) (length branch)) 105 | (loop for key being the hash-key of branch using (hash-value next-to-prune) 106 | for next-example = (trie-search example `(,key)) 107 | if next-example do (trie-prune next-to-prune next-example) 108 | else do (remhash key branch)))) 109 | to-prune) 110 | 111 | (defun TRIE-LIST-VALUES (trie) 112 | "Recursively list all values in the trie." 113 | (let* ((branch (trie-branch trie)) 114 | (children 115 | (if (listp branch) 116 | (loop for (nil . next-trie) in branch 117 | nconc (trie-list-values next-trie)) 118 | (loop for next-trie being the hash-value of branch 119 | nconc (trie-list-values next-trie))))) 120 | (aif (trie-value trie) 121 | (cons it children) 122 | children))) 123 | 124 | (defun TRIE-LIST-DEPTH (trie depth) 125 | "List all values at the given depth (0 is the top level)." 126 | (cond ((< depth 0) nil) 127 | ((= depth 0) (awhen (trie-value trie) (list it))) 128 | (t (let ((branch (trie-branch trie))) 129 | (if (listp branch) 130 | (loop for (nil . next-trie) in branch 131 | nconc (trie-list-depth next-trie (1- depth))) 132 | (loop for next-trie being the hash-value of branch 133 | nconc (trie-list-depth next-trie (1- depth)))))))) 134 | 135 | (defun TRIE-LIST-BOTTOM (trie) 136 | "List all values at the bottom of the trie (i.e. values of all tries 137 | with no branches)." 138 | (if (= (trie-count trie) 0) 139 | (list (trie-value trie)) 140 | (let ((branch (trie-branch trie))) 141 | (if (listp branch) 142 | (loop for (nil . next-trie) in branch 143 | nconc (trie-list-bottom next-trie)) 144 | (loop for next-trie being the hash-value of branch 145 | nconc (trie-list-bottom next-trie)))))) 146 | 147 | (defun TRIE-BOTTOM-P (trie) 148 | "Returns t if the given trie has no branches." 149 | (let ((branch (trie-branch trie))) 150 | (or (null branch) 151 | (and (hash-table-p branch) 152 | (= 0 (hash-table-count branch)))))) 153 | 154 | (defun %TRIE-MAP-TRIE (fn new-trie trie &rest tries) 155 | "Create a new trie with the same structure as trie, applying fn to 156 | each trie-node in turn." 157 | (setf (trie-value new-trie) (apply fn trie tries)) 158 | (let ((branch (trie-branch trie))) 159 | (if (listp branch) 160 | (loop for (key . next-trie) in branch 161 | for next-tries = (mapcar (lambda (x) (trie-search x `(,key))) tries) 162 | for no-op = (member nil next-tries) ;; abort if we don't find a key. 163 | for next-new-trie = (unless no-op (trie-insert nil new-trie `(,key))) 164 | unless no-op 165 | do (apply #'%trie-map-trie fn next-new-trie next-trie next-tries)) 166 | ;; regrettable copying of code. 167 | (loop for next-trie being the hash-value of branch using (hash-key key) 168 | for next-tries = (mapcar (lambda (x) (trie-search x `(,key))) tries) 169 | for no-op = (member nil next-tries) ;; abort if we don't find a key. 170 | for next-new-trie = (unless no-op (trie-insert nil new-trie `(,key))) 171 | unless no-op 172 | do (apply #'%trie-map-trie fn next-new-trie next-trie next-tries)))) 173 | new-trie) 174 | 175 | (defun TRIE-MAP-B (fn trie) 176 | "Apply fn to each branch of trie. Returns the trie." 177 | (let ((branch (trie-branch trie))) 178 | (if (listp branch) 179 | (loop for (nil . next-trie) in branch 180 | do (funcall fn next-trie)) 181 | (loop for next-trie being the hash-value of branch 182 | do (funcall fn next-trie))))) 183 | 184 | (defmacro DO-TRIE-BRANCHES ((next-trie trie &optional result) &body body) 185 | "Loop over the trie's branches." 186 | `(progn 187 | (trie-map-b (lambda (,next-trie) ,@body) ,trie) 188 | ,result)) 189 | 190 | (defun TRIE-MAP-BRANCHES (fn trie) 191 | "Apply fn to each branch of trie. Returns a list of the returned values." 192 | (let (list) 193 | (trie-map-b (lambda (x) (push (funcall fn x) list)) trie) 194 | (nreverse list))) 195 | 196 | (defun TRIE-BRANCH-VALUES (trie) 197 | "Return (key . trie-value) for each branch of trie." 198 | (let ((branch (trie-branch trie))) 199 | (if (listp branch) 200 | (loop for (key . next-trie) in branch 201 | collect (cons key (trie-value next-trie))) 202 | (loop for next-trie being the hash-value of branch using (hash-key key) 203 | collect (cons key (trie-value next-trie)))))) 204 | 205 | (defun TRIE-MAP-TRIE (fn trie &rest tries) 206 | "Apply fn to the given trie and its children, returning the results 207 | as the values of a matching trie." 208 | (apply #'%trie-map-trie fn (make-trie :test (trie-test trie)) trie tries)) 209 | 210 | (defun TRIE-MAP-VALUES (fn trie) 211 | "Apply fn to the given trie's non-nil values, returning the results 212 | as the values of a matching trie." 213 | (trie-map-trie (lambda (trie) 214 | (awhen (trie-value trie) 215 | (funcall fn it))) 216 | trie)) 217 | 218 | (defmacro DO-TRIE-VALUES ((value trie &optional retval) &body body) 219 | `(block nil 220 | (trie-map-values (lambda (,value) ,@body) ,trie) 221 | ,retval)) 222 | 223 | (defun %TRIE-MAP-KEY-VALUE (fn key trie new-trie) 224 | "Create a new trie with the same structure as trie, applying fn to 225 | the key and the old trie node." 226 | (setf (trie-value new-trie) (funcall fn key trie)) 227 | (let ((branch (trie-branch trie))) 228 | (if (listp branch) 229 | (loop for (next-key . next-trie) in branch 230 | for next-new-trie = (trie-insert nil new-trie `(,next-key)) 231 | do (%trie-map-key-value fn `(,@key ,next-key) next-trie next-new-trie)) 232 | (loop for next-trie being the hash-value of branch using (hash-key next-key) 233 | for next-new-trie = (trie-insert nil new-trie `(,next-key)) 234 | do (%trie-map-key-value fn `(,@key ,next-key) next-trie next-new-trie)))) 235 | new-trie) 236 | 237 | (defun TRIE-MAP-KEY-VALUE (fn trie) 238 | "Create a new trie with the same structure as trie, applying fn to 239 | the key and the old trie node." 240 | (%trie-map-key-value fn nil trie (make-trie :test (trie-test trie)))) 241 | 242 | (defun HASH-TO-TRIE (hash &key (trie (make-trie :test (hash-table-test hash))) 243 | (trie-key #'identity) (trie-value #'identity) bagp) 244 | "Add the elements of hash to the given trie (if no trie is given, 245 | make one with the same test as the hash table. trie-key (default 246 | #'identity) is a function to apply to the hash-key. It should 247 | convert the hash-key to a list of atoms which are compatible with 248 | the trie's test. trie-value (default #'identity) is a function to 249 | extract the value of interest from the actual value (or the key if 250 | bagp is non-nil) held in the hash." 251 | (loop 252 | for key being the hash-key of hash using (hash-value value) do 253 | (trie-insert (funcall trie-value (if bagp key value)) 254 | trie (funcall trie-key key)) 255 | finally (return trie))) 256 | 257 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; utils - general utility macros and functions. 3 | ;; 4 | ;; Copyright (c) 2007-2013, Lucas Hope . 5 | ;; Copyright other contributors as noted in the AUTHORS file. 6 | ;; 7 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 8 | ;; Inference Engine. 9 | ;; 10 | ;; This file is licensed under the terms of the LLGPL. 11 | ;; 12 | ;; This library is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the Lisp Lesser General Public License version 14 | ;; 3, which consists of the GNU Lesser General Public License, either 15 | ;; version 3 or (at your option) any later version, as published by the 16 | ;; Free Software Foundation, and the Franz preamble. 17 | ;; 18 | ;; This library is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 21 | ;; Lesser General Public License for more details. 22 | 23 | (in-package :cl-bayesnet) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (defmacro with-gensyms ((&rest symbols) &body body) 27 | `(let ,(mapcar #'(lambda (symbol) `(,symbol (gensym))) 28 | symbols) 29 | ,@body))) 30 | 31 | (defmacro while (expr &body body) 32 | "Continue performing body until expr is false." 33 | `(do () 34 | ((not ,expr)) 35 | ,@body)) 36 | 37 | (defmacro aif (test-form then-form &optional else-form) 38 | "Anaphoric if. (lexically sets 'it' to the test-form, which can 39 | then be referenced in then-form and else-form." 40 | `(let ((it ,test-form)) 41 | (if it ,then-form ,else-form))) 42 | 43 | (defmacro awhen (test-form &body body) 44 | "Anaphoric when. See aif." 45 | `(aif ,test-form 46 | (progn ,@body))) 47 | 48 | (defmacro returnit (val &body body) 49 | "An anaphorous macro. binds the first val to `it', allows possible modifications 50 | in the body, then returns the values. A more general prog1." 51 | `(let ((it ,val)) ,@body it)) 52 | 53 | (defmacro multf (ref multiplier) 54 | "(setf ref (* ref multiplier)). Like incf." 55 | `(setf ,ref (* ,ref ,multiplier))) 56 | 57 | (defvar *calculation-context* nil 58 | "Used by with-calculation(-context) to define a limited caching 59 | environment.") 60 | 61 | (defmacro with-calculation-context ((&optional (test 'equalp)) 62 | &body body) 63 | "Defines a calculation context within which calculations performed 64 | within with-calculation are cached according to their label." 65 | `(let ((*calculation-context* (make-hash-table :test ',test))) 66 | ,@body)) 67 | 68 | (defmacro with-calculation (label &body body) 69 | "Unless label is nil, caches the calculation performed by body using label. 70 | If there is no calculation-context, does not evaluate label, so 71 | don't rely on side effects." 72 | (with-gensyms (glabel gvalue gpresent-p) 73 | `(let ((,glabel (and *calculation-context* ,label))) 74 | (multiple-value-bind (,gvalue ,gpresent-p) 75 | (and ,glabel *calculation-context* 76 | (gethash ,glabel *calculation-context*)) 77 | (if ,gpresent-p ,gvalue 78 | (prog1 (setf ,gvalue (progn ,@body)) 79 | (when (and ,glabel *calculation-context*) 80 | (setf (gethash ,glabel *calculation-context*) 81 | ,gvalue)))))))) 82 | 83 | ;; function composition 84 | (defun compose (&rest fns) 85 | "Create a function which is the composition of the given functions." 86 | (destructuring-bind (fn1 . rest) (reverse fns) 87 | (lambda (&rest args) 88 | (reduce (lambda (v f) (funcall f v)) 89 | rest 90 | :initial-value (apply fn1 args))))) 91 | 92 | (defun maparray (fn array) 93 | "maparray applies fn to all elements in 94 | array, returning the result in an array the 95 | same dimension as the first array" 96 | (let ((retval (make-array (array-dimensions array))) 97 | (length (array-total-size array))) 98 | (dotimes (i length retval) 99 | (setf (row-major-aref retval i) 100 | (funcall fn (row-major-aref array i)))))) 101 | 102 | (defun copy-array (array) 103 | (maparray #'identity array)) 104 | 105 | (defun cpt-incf (att-state att-mask) 106 | "Increments att-state according to att-mask; att-state and att-mask 107 | are vectors. att-mask is nil for non-included attributes and the 108 | number of values for included attributes. It takes (reduce 109 | #'* (remove nil att-mask)) to iterate through att-state. att-state 110 | must be a positive integer below the mask's value, wherever mask is 111 | non-nil." 112 | (dotimes (i (length att-mask)) 113 | (awhen (aref att-mask i) 114 | (let ((state (incf (aref att-state i)))) 115 | (if (= it state) 116 | (setf (aref att-state i) 0) 117 | (return))))) 118 | att-state) 119 | 120 | (defun cpt-index (mask att-state) 121 | "Given the mask and att-state, return an index. Used to map 122 | attribute values to a single lookup value in a table." 123 | (loop with multiplier = 1 124 | with index = 0 125 | for state across mask 126 | for value across att-state 127 | do (when state 128 | (incf index (* multiplier value)) 129 | (setf multiplier (* multiplier state))) 130 | finally (return index))) 131 | 132 | (defun map-int (fn n) 133 | "Map fn across integers from 0 below n, returning the results in 134 | an (ordered) list." 135 | (let ((acc nil)) 136 | (dotimes (i n) 137 | (push (funcall fn i) acc)) 138 | (nreverse acc))) 139 | 140 | (defun best-in-list (list compare &key (key #'identity)) 141 | "return the best value in list, along with its position and its comparison value. See best." 142 | (loop with best-arg = 0 and best-val = (car list) 143 | with best-eval = (funcall key best-val) 144 | for arg from 1 145 | for val in (cdr list) 146 | for eval = (funcall key val) 147 | when (funcall compare eval best-eval) 148 | do (setq best-arg arg best-val val best-eval eval) 149 | finally (return (values best-val best-arg best-eval)))) 150 | 151 | (defun best-in-array (array compare &key (key #'identity)) 152 | "return the best value in array, along with its position and its comparison value. See best." 153 | (loop with best-arg = 0 and best-val = (aref array 0) 154 | with best-eval = (funcall key best-val) 155 | for arg from 1 below (length array) 156 | for val = (aref array arg) 157 | for eval = (funcall key val) 158 | when (funcall compare eval best-eval) 159 | do (setq best-arg arg best-val val best-eval eval) 160 | finally (return (values best-val best-arg best-eval)))) 161 | 162 | (defun best-in-hash (hash compare &key (key #'identity)) 163 | "return the best value in hash along with its hash-key and its comparison value. See best." 164 | (loop with best-arg and best-val and best-eval 165 | for arg being the hash-key of hash using (hash-value val) 166 | for eval = (funcall key val) 167 | when (or (null best-eval) (funcall compare eval best-eval)) 168 | do (setq best-arg arg best-val val best-eval eval) 169 | finally (return (values best-val best-arg best-eval)))) 170 | 171 | (defun best (seq/hash compare &key (key #'identity)) 172 | "Returns the best value in seq/hash, along with its position (or key 173 | for the hash), according to compare. The comparison value is returned 174 | as a third value. key extracts the value to be used for comparison." 175 | (etypecase seq/hash 176 | (null nil) 177 | (cons (best-in-list seq/hash compare :key key)) 178 | (sequence (best-in-array seq/hash compare :key key)) 179 | (hash-table (best-in-hash seq/hash compare :key key)))) 180 | 181 | (defun make-vector (len &optional initarg) 182 | (make-array len :initial-element initarg)) 183 | 184 | (defun normalize (vec &optional smoothing-factor) 185 | "Normalize a vector. Optionally adds smoothing-factor (which should 186 | be a number) to each element first. If tot is less than or equal to 187 | 0." 188 | (let ((tot (reduce #'+ vec :initial-value 189 | (if smoothing-factor (* smoothing-factor (length vec)) 0)))) 190 | (cond ((= (length vec) 0) #()) 191 | ((<= tot 0) (make-array (length vec) :initial-element (/ (length vec)))) 192 | (t (map 'vector (if smoothing-factor 193 | (lambda (x) (/ (+ x smoothing-factor) tot)) 194 | (lambda (x) (/ x tot))) 195 | vec))))) 196 | 197 | (defun order-vector (end &optional (start 0)) 198 | "Create a vector of length (end - start), filled with numbers from 199 | start...(end - 1). Start defaults to 0." 200 | (let ((vec (make-array (- end start) :element-type 'fixnum :initial-element 0))) 201 | (dotimes (i (length vec) vec) 202 | (setf (aref vec i) (+ i start))))) 203 | 204 | (defgeneric shuffle (object) 205 | (:documentation 206 | "Randomise the object, which should represent a sequence.")) 207 | 208 | (defmethod shuffle ((vector vector)) 209 | "shuffle the items in vector into a random order." 210 | (let ((len (length vector))) 211 | (dotimes (i (1- len) vector) 212 | (rotatef (aref vector i) (aref vector (+ i (random (- len i)))))))) 213 | 214 | (defmethod shuffle ((sequence sequence)) 215 | "shuffle the items in the sequence into a random order. Converts the sequence to a vector." 216 | (let ((type (type-of sequence))) 217 | (coerce (shuffle (coerce sequence 'vector)) type))) 218 | 219 | (defmethod shuffle ((length integer)) 220 | "Create a vector of the given length using order-vector, and shuffle it." 221 | (shuffle (order-vector length))) 222 | -------------------------------------------------------------------------------- /tests/emit-java.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; emit-java - Write out java source code from Arithmetic Circuit 3 | ;; instructions. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | 26 | ;; this is copied from hunchentoot/test/test.lisp, used to locate static files. 27 | (defvar *emit-java-file* (load-time-value 28 | (or #.*compile-file-pathname* *load-pathname*))) 29 | 30 | (defun emit-java-double (double) 31 | (let ((str (write-to-string double))) 32 | (concatenate 'string (nsubstitute #\E #\d str) "d"))) 33 | 34 | (defun emit-java-header (package-name class-name stream) 35 | "Write out the package and class names for the net." 36 | (format stream "// Created using the cl-bayesnet package.~%") 37 | (format stream "package ~A;~%" package-name) 38 | (write-line "import java.util.Hashtable;" stream) 39 | (format stream "public class ~A implements bn.java.BN {~%" class-name) 40 | (format stream " public ~A() {~%" class-name) 41 | (with-open-file (resource (merge-pathnames "java/BN.resource" 42 | (directory-namestring *emit-java-file*))) 43 | (loop for line = (read-line resource nil nil) 44 | while line do (write-line line stream)))) 45 | 46 | (defun emit-java-num-nodes (num stream) 47 | "public abstract int getNumNodes();" 48 | (format stream "public int getNumNodes() { return ~A; }~%" num)) 49 | 50 | (defun emit-java-num-states (state-list stream) 51 | "public abstract int getNumStates(int node);" 52 | (let ((*standard-output* stream)) 53 | (format t "private int[] numStates = new int[] { ~{~a~^, ~} };~%" state-list) 54 | (write-line "public int getNumStates(int node) { return numStates[node]; }") 55 | nil)) 56 | 57 | (defun emit-java-node-names (names stream) 58 | "public abstract java.lang.String[] getNodeNames();" 59 | (let ((*standard-output* stream)) 60 | (write-line "private java.lang.String[] nodeNames =") 61 | (format t " new java.lang.String[] { ~{~s~^, ~} };~%" names) 62 | (write-line "public java.lang.String[] getNodeNames() { return nodeNames; }") 63 | nil)) 64 | 65 | (defun emit-java-state-names (names-list stream) 66 | "public abstract java.lang.String[] getStateNames(int node);" 67 | (let ((*standard-output* stream)) 68 | (write-line "private java.lang.String[][] stateNames =") 69 | (write-string " new java.lang.String[][] { ") 70 | (format t "~{~% new java.lang.String[] { ~{~s~^, ~} }~^, ~} };~%" names-list) 71 | (write-line 72 | "public java.lang.String[] getStateNames(int node) { return stateNames[node]; }") 73 | nil)) 74 | 75 | (defun emit-java-query (forms stream) 76 | "public abstract double query(int[] netspec);" 77 | (write-line "public double query(int[] netspec) {" stream) 78 | (loop 79 | for inst in forms 80 | for var = 0 then (1+ var) 81 | for rhs = (if (numberp (car inst)) 82 | (format nil "match(netspec[~A], ~A)" (car inst) (cdr inst)) 83 | (let ((op-string (format nil " ~A " (car inst)))) 84 | (with-output-to-string (*standard-output*) 85 | (loop for cons on (cdr inst) 86 | do (let ((val (car cons))) 87 | (if (floatp val) (write-string (emit-java-double val)) 88 | (format t "v~A" val))) 89 | when (cdr cons) do (write-string op-string))))) 90 | do 91 | (format stream " double v~A = ~A;~%" var rhs) 92 | finally (format stream " return v~A;~%}~%" var))) 93 | 94 | 95 | (defun emit-java-footer (stream) 96 | "Write out the footer for the net." 97 | (write-line "}" stream)) 98 | 99 | (defun emit-java-net (net 100 | &optional (package-name "bn.java") (stream *standard-output*)) 101 | (let ((ins (gen-instructions net))) 102 | (with-slots (forms form-count) ins 103 | (emit-java-header package-name (name net) stream) 104 | (emit-java-num-nodes (num-nodes net) stream) 105 | (emit-java-num-states (map 'list #'num-states (node-vec net)) 106 | stream) 107 | (emit-java-node-names (map 'list (lambda (x) (string-downcase (string (name x)))) 108 | (node-vec net)) stream) 109 | (emit-java-state-names 110 | (map 'list (lambda (x) (map 'list (lambda (x) (string-downcase (string x))) 111 | (states x))) (node-vec net)) stream) 112 | (emit-java-query forms stream) 113 | (emit-java-footer stream) 114 | nil))) 115 | 116 | (defun write-java-net (file net &optional (package-name "bn.java")) 117 | (with-open-file (s file :direction :output) 118 | (emit-java-net net package-name s))) 119 | 120 | -------------------------------------------------------------------------------- /tests/emit-lisp.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; emit-lisp - Write out lisp source code from Arithmetic Circuit 3 | ;; instructions. 4 | ;; 5 | ;; Copyright (c) 2007-2013, Lucas Hope . 6 | ;; Copyright other contributors as noted in the AUTHORS file. 7 | ;; 8 | ;; This file is part of cl-bayesnet - a Common Lisp Bayesian Network 9 | ;; Inference Engine. 10 | ;; 11 | ;; This file is licensed under the terms of the LLGPL. 12 | ;; 13 | ;; This library is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the Lisp Lesser General Public License version 15 | ;; 3, which consists of the GNU Lesser General Public License, either 16 | ;; version 3 or (at your option) any later version, as published by the 17 | ;; Free Software Foundation, and the Franz preamble. 18 | ;; 19 | ;; This library is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;; Lesser General Public License for more details. 23 | 24 | (in-package :cl-bayesnet) 25 | ;;;; 26 | ;;;; The below code is obsolete. There is not yet any point to 27 | ;;;; rewriting it, because the SBCL compiler is too slow to be relied 28 | ;;;; upon. 29 | ;;;; 30 | 31 | (defun emit-lisp-bind (array-symbol var-array) 32 | (loop 33 | for var across var-array 34 | for index = 0 then (1+ index) 35 | collect `(,var (svref ,array-symbol ,index)))) 36 | 37 | (defun compile-lisp-net (net) 38 | (multiple-value-bind (forms result var-array form-count) 39 | (emit-instructions net) 40 | (let* ((net-spec (gentemp "NET")) 41 | (func `(lambda (,net-spec) 42 | (let ,(emit-lisp-bind net-spec var-array) 43 | (let* ,forms 44 | ,result))))) 45 | (setf (compiled net) (compile nil func)) 46 | (values func form-count)))) 47 | -------------------------------------------------------------------------------- /tests/java/BN.java: -------------------------------------------------------------------------------- 1 | /* 2 | This is free and unencumbered software released into the public 3 | domain. 4 | 5 | Anyone is free to copy, modify, publish, use, compile, sell, or 6 | distribute this software, either in source code form or as a 7 | compiled binary, for any purpose, commercial or non-commercial, and 8 | by any means. 9 | 10 | In jurisdictions that recognize copyright laws, the author or 11 | authors of this software dedicate any and all copyright interest in 12 | the software to the public domain. We make this dedication for the 13 | benefit of the public at large and to the detriment of our heirs and 14 | successors. We intend this dedication to be an overt act of 15 | relinquishment in perpetuity of all present and future rights to 16 | this software under copyright law. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY 22 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 23 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 24 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | For more information, please refer to 27 | */ 28 | 29 | package bn.java; 30 | 31 | /** 32 | This is a minimal interface for Bayesian network queries. The 33 | interface allows probability queries by node index or name. No 34 | facility is provided for inquiring into the underlying Bayesian 35 | network structure. 36 | 37 | It allows the most common queries: conditional and unconditional 38 | probabilities of nodes, as well as unconditional queries across 39 | multiple nodes. 40 | 41 | Access is also provided to the underlying query engine so further 42 | query types can be constructed. 43 | 44 | Copyright (c) 2007, Lucas Hope. 45 | */ 46 | public interface BN { 47 | 48 | /** Return the number of nodes in the Bayesian network. */ 49 | public int getNumNodes(); 50 | 51 | /** Return an array of the names of each node in order. This 52 | * array should not be modified. */ 53 | public java.lang.String[] getNodeNames(); 54 | 55 | /** Return the number of states in the numbered node. */ 56 | public int getNumStates(int node); 57 | 58 | /** Return the number of states in the named node. */ 59 | public int getNumStates(java.lang.String node); 60 | 61 | /** Return an array of the state names in the numbered node. This 62 | * array should not be modified. */ 63 | public java.lang.String[] getStateNames(int node); 64 | 65 | /** Return an array of the state names in the named node. This 66 | * array should not be modified. */ 67 | public java.lang.String[] getStateNames(java.lang.String node); 68 | 69 | /** Return the unconditional prior probability of the node. 70 | * @return A normalized array of probababilities. 71 | */ 72 | public double[] query(int node); 73 | 74 | /** Return the unconditional prior probability of the node. 75 | * @return A normalized array of probababilities. 76 | */ 77 | public double[] query(java.lang.String node); 78 | 79 | /** Return the probability that all the nodes are in the given 80 | * states. 81 | * @return a probability. 82 | */ 83 | public double query(int[] nodes, int[] states); 84 | 85 | /** Return the probability that all the nodes are in the given 86 | * states. 87 | * @return a probability. 88 | */ 89 | public double query(java.lang.String[] nodes, java.lang.String[] states); 90 | 91 | /** Return the conditional probability distribution of node given 92 | * the nodes are in the given states. 93 | * @return A normalized array of probababilities. 94 | */ 95 | public double[] query(int node, int[] nodes, int[] states); 96 | 97 | /** Return the conditional probability distribution of node given 98 | * the nodes are in the given states. 99 | * @return A normalized array of probababilities. 100 | */ 101 | public double[] query(java.lang.String node, 102 | java.lang.String[] nodes, java.lang.String[] states); 103 | 104 | /** Return the probability that the node is in the given state. 105 | @param state An array of length getNumNodes(), 106 | whose elements are the node states (less than zero indicates 107 | no evidence). 108 | @return a probability. 109 | */ 110 | public double query(int[] state); 111 | 112 | } 113 | -------------------------------------------------------------------------------- /tests/java/BN.resource: -------------------------------------------------------------------------------- 1 | // Start BN.resource 2 | /* 3 | This is free and unencumbered software released into the public 4 | domain. 5 | 6 | Anyone is free to copy, modify, publish, use, compile, sell, or 7 | distribute this software, either in source code form or as a 8 | compiled binary, for any purpose, commercial or non-commercial, and 9 | by any means. 10 | 11 | In jurisdictions that recognize copyright laws, the author or 12 | authors of this software dedicate any and all copyright interest in 13 | the software to the public domain. We make this dedication for the 14 | benefit of the public at large and to the detriment of our heirs 15 | and successors. We intend this dedication to be an overt act of 16 | relinquishment in perpetuity of all present and future rights to 17 | this software under copyright law. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 21 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY 23 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 24 | CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 25 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 26 | 27 | For more information, please refer to 28 | */ 29 | String[] nodeNames = getNodeNames(); 30 | 31 | //stateHashes = new Hashtable[getNumNodes()]; 32 | stateHashes = new Hashtable[getNumNodes()]; 33 | 34 | for(int i = 0; i < nodeNames.length; i ++) { 35 | nodeHash.put(nodeNames[i],i); 36 | String[] states = getStateNames(i); 37 | stateHashes[i] = 38 | new Hashtable(); 39 | for(int j = 0; j < states.length; j ++) 40 | { stateHashes[i].put(states[j],j); } 41 | } 42 | } 43 | 44 | /** A hash table mapping node name to its index. */ 45 | protected Hashtable nodeHash = 46 | new Hashtable(); 47 | 48 | /** An array of hashes mapping state names to indices. */ 49 | protected Hashtable[] stateHashes; 50 | 51 | /** Returns 1 if val is possible, given state and 0 otherwise. If 52 | * state is less than 0, anything is possible. */ 53 | protected static double match(int state, int val) { 54 | if(state < 0) { return 1.0; } 55 | return (state == val) ? 1.0 : 0.0; 56 | } 57 | 58 | /** Destructively normalize vec. Assumes vec is non-zero. */ 59 | protected static double[] normalize(double[] vec) { 60 | double tot = 0.0d; 61 | for(int i = 0; i < vec.length; i ++) 62 | { tot += vec[i]; } 63 | for(int i = 0; i < vec.length; i ++) 64 | { vec[i] /= tot; } 65 | 66 | return vec; 67 | } 68 | 69 | /** Returns a fresh array of length getNumNodes, initialized to 70 | * -1. */ 71 | protected int[] netState() { 72 | int[] retval = new int[getNumNodes()]; 73 | for(int i = 0; i < retval.length; i ++) 74 | { retval[i] = -1; } 75 | return retval; 76 | } 77 | 78 | 79 | /** Return the unconditional prior probability of node. */ 80 | public double[] query(int node) { 81 | int[] netState = netState(); 82 | double[] prob = new double[getNumStates(node)]; 83 | for(int i = 0; i < prob.length; i ++) { 84 | netState[node] = i; 85 | prob[i] = query(netState); 86 | } 87 | 88 | return normalize(prob); 89 | } 90 | 91 | /** Return the probability that all the nodes are in the given 92 | * states. */ 93 | public double query(int[] nodes, int[] states) { 94 | int[] netState = netState(); 95 | 96 | for(int i = 0; i < nodes.length; i ++) 97 | { netState[nodes[i]] = states[i]; } 98 | 99 | return query(netState); 100 | } 101 | 102 | /** Returns the conditional probability distribution of node given 103 | * the nodes are in the given states. */ 104 | public double[] query(int node, int[] nodes, int[] states) 105 | { 106 | int[] netState = netState(); 107 | 108 | for(int i = 0; i < nodes.length; i ++) 109 | { netState[nodes[i]] = states[i]; } 110 | 111 | double[] prob = new double[getNumStates(node)]; 112 | for(int i = 0; i < prob.length; i ++) { 113 | netState[node] = i; 114 | prob[i] = query(netState); 115 | } 116 | 117 | return normalize(prob); 118 | } 119 | 120 | /** Return the unconditional prior probability of node. */ 121 | public double[] query(java.lang.String node) { 122 | return query(nodeHash.get(node)); 123 | } 124 | 125 | /** Return the probability that all the nodes are in the given 126 | * states. */ 127 | public double query(java.lang.String[] nodes, java.lang.String[] states) { 128 | int[] nodeNums = new int[nodes.length]; 129 | int[] stateNums = new int[nodes.length]; 130 | 131 | for(int i = 0; i < nodes.length; i ++) { 132 | nodeNums[i] = nodeHash.get(nodes[i]); 133 | stateNums[i] = stateHashes[nodeNums[i]].get(states[i]); 134 | } 135 | return query(nodeNums, stateNums); 136 | } 137 | 138 | /** Returns the conditional probability distribution of node given 139 | * the nodes are in the given states. */ 140 | public double[] query(java.lang.String node, 141 | java.lang.String[] nodes, java.lang.String[] states) { 142 | int[] nodeNums = new int[nodes.length]; 143 | int[] stateNums = new int[nodes.length]; 144 | 145 | for(int i = 0; i < nodes.length; i ++) { 146 | nodeNums[i] = nodeHash.get(nodes[i]); 147 | stateNums[i] = stateHashes[nodeNums[i]].get(states[i]); 148 | } 149 | return query(nodeHash.get(node), nodeNums, stateNums); 150 | } 151 | 152 | public java.lang.String[] getStateNames(java.lang.String node) 153 | { 154 | return getStateNames(nodeHash.get(node)); 155 | } 156 | 157 | public int getNumStates(java.lang.String node) 158 | { 159 | return getNumStates(nodeHash.get(node)); 160 | } 161 | // End BN.resource 162 | -------------------------------------------------------------------------------- /tests/test-alarm.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; test-alarm - Test/example usage code. Note this is public domain. 3 | ;; 4 | ;; This is free and unencumbered software released into the public domain. 5 | ;; 6 | ;; Anyone is free to copy, modify, publish, use, compile, sell, or 7 | ;; distribute this software, either in source code form or as a compiled 8 | ;; binary, for any purpose, commercial or non-commercial, and by any 9 | ;; means. 10 | ;; 11 | ;; In jurisdictions that recognize copyright laws, the author or authors 12 | ;; of this software dedicate any and all copyright interest in the 13 | ;; software to the public domain. We make this dedication for the benefit 14 | ;; of the public at large and to the detriment of our heirs and 15 | ;; successors. We intend this dedication to be an overt act of 16 | ;; relinquishment in perpetuity of all present and future rights to this 17 | ;; software under copyright law. 18 | ;; 19 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 21 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 22 | ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 23 | ;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 24 | ;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | ;; OTHER DEALINGS IN THE SOFTWARE. 26 | ;; 27 | ;; For more information, please refer to 28 | 29 | (in-package :cl-user) 30 | 31 | (defparameter *join-tree* 32 | (bn:load-dne (merge-pathnames "git/cl-bayesnet/nets/alarm.dne" 33 | (user-homedir-pathname)))) 34 | 35 | (defparameter *interpreted* 36 | (bn:load-xmlbif (merge-pathnames "git/cl-bayesnet/nets/alarm.xml" 37 | (user-homedir-pathname)))) 38 | 39 | (defparameter *compiled-c* 40 | (bn:load-xmlbif (merge-pathnames "git/cl-bayesnet/nets/alarm.xml" 41 | (user-homedir-pathname)))) 42 | 43 | (time 44 | (defparameter *jt* (bn:use-join-tree *join-tree*))) 45 | ;; 0.033 seconds of real time 46 | 47 | (time 48 | (defparameter *instructions* (bn:use-interpreted *interpreted*))) 49 | ;; 27.236 seconds of real time 50 | 51 | (time 52 | (bn:use-compiled-c *compiled-c*)) 53 | ;; 28.207 seconds of real time 54 | 55 | (bn:node-order *join-tree*) ;; dne 56 | #(:HYPOVOLEMIA :LVFAILURE :LVEDVOLUME :STROKEVOLUME :CVP :PCWP :INSUFFANESTH 57 | :PULMEMBOLUS :INTUBATION :SHUNT :KINKEDTUBE :MINVOLSET :VENTMACH :DISCONNECT 58 | :VENTTUBE :VENTLUNG :VENTALV :FIO2 :PVSAT :SAO2 :ANAPHYLAXIS :TPR :ARTCO2 59 | :CATECHOL :HR :CO :HISTORY :BP :ERRCAUTER :HREKG :HRSAT :ERRLOWOUTPUT :HRBP 60 | :EXPCO2 :PAP :PRESS :MINVOL) 61 | 62 | (bn:node-order *interpreted*) ;; bif 63 | #(:HYPOVOLEMIA :STROKEVOLUME :LVFAILURE :LVEDVOLUME :PCWP :CVP :HISTORY 64 | :MINVOLSET :VENTMACH :DISCONNECT :VENTTUBE :KINKEDTUBE :PRESS :ERRLOWOUTPUT 65 | :HRBP :ERRCAUTER :HREKG :HRSAT :BP :CO :HR :TPR :ANAPHYLAXIS :INSUFFANESTH 66 | :PAP :PULMEMBOLUS :FIO2 :CATECHOL :SAO2 :SHUNT :PVSAT :MINVOL :EXPCO2 :ARTCO2 67 | :VENTALV :VENTLUNG :INTUBATION) 68 | 69 | (bn:states (bn:node :hypovolemia *compiled-c*)) 70 | #(:TRUE :FALSE) 71 | 72 | (bn:states (bn:node :bp *compiled-c*)) 73 | #(:LOW :NORMAL :HIGH) 74 | 75 | ;; For queries you can use the join-tree object same as the net object. 76 | ;; I use *jt* to demonstrate 77 | (bn:query *jt* '(:bp :low :history :false)) 78 | 0.41846273520929067d0 79 | 80 | (bn:query *interpreted* '(:bp :low :history :false)) 81 | 0.41846274444015086d0 82 | 83 | (bn:query *compiled-c* '(:bp :low :history :false)) 84 | 0.41846274444015086d0 85 | 86 | (bn:query (bn:node :hrbp *jt*)) 87 | #(0.07128078734685757d0 0.4167348123134152d0 0.5119844003397273d0) 88 | 89 | (bn:query (bn:node :hrbp *interpreted*)) 90 | #(0.07128078957655479d0 0.4167348170680417d0 0.5119843933554036d0) 91 | 92 | (bn:query (bn:node :hrbp *compiled-c*)) 93 | #(0.07128078957655479d0 0.4167348170680417d0 0.5119843933554036d0) 94 | 95 | (bn:query (bn:node :hrbp *jt*) '(:ventlung :zero)) 96 | #(0.037591916440952444d0 0.13858216958572717d0 0.8238259139733204d0) 97 | 98 | (bn:query (bn:node :hrbp *interpreted*) '(:ventlung :zero)) 99 | #(0.03759191698211968d0 0.13858217452537563d0 0.8238259084925047d0) 100 | 101 | (bn:query (bn:node :hrbp *compiled-c*) '(:ventlung :zero)) 102 | #(0.03759191698211968d0 0.13858217452537563d0 0.8238259084925047d0) 103 | 104 | ;; some speed tests. 105 | (progn 106 | (time 107 | (length (bn::test-net-random *compiled-c* 100000)))) 108 | ;; 0.636 seconds of real time 109 | 110 | (progn 111 | (time 112 | (length (bn::test-net-random *interpreted* 100000)))) 113 | ;; 12.010 seconds of real time 114 | 115 | ;; Here we use only 1000 because join tree is much slower. 116 | (progn 117 | (time 118 | (length (bn::test-net-random *join-tree* 1000)))) 119 | ;; 8.281 seconds of real time 120 | 121 | ;; Evidence 122 | (bn:with-evidence (*compiled-c* :ventlung 0 :pcwp 0) 123 | (bn:query *compiled-c*)) 124 | 0.029107331259445833d0 125 | 126 | (bn:states (bn:node :hrbp *compiled-c*)) 127 | #(:LOW :NORMAL :HIGH) 128 | 129 | (bn:with-evidence (*compiled-c* :ventlung :high :pcwp :high) 130 | (bn:query (bn:node :hrbp *compiled-c*))) 131 | #(0.09471917513150513d0 0.6102541714395288d0 0.2950266534289663d0) 132 | --------------------------------------------------------------------------------