├── LICENSE ├── README.md └── code ├── advanced-hangouts ├── hangout-6 │ ├── EXPLANATION.md │ ├── fastest-bench-map.txt │ ├── interp-fastest-fixed-application-optimization.scm │ ├── interp-fastest-fixed.scm │ ├── interp-fastest.scm │ ├── interp-inlined-prims-with-dummy-evalo-dispatch-application-optimization.scm │ ├── interp-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── interp-inlined-prims-with-real-evalo-dispatch.scm │ ├── interp-inlined-prims.scm │ ├── interp-old-style.scm │ ├── mk-vicare.scm │ ├── mk.rkt │ ├── mk.scm │ ├── test-check.scm │ ├── test-interp-fastest-fixed-application-optimization.scm │ ├── test-interp-fastest-fixed.scm │ ├── test-interp-fastest.scm │ ├── test-interp-inlined-prims-with-dummy-evalo-dispatch-application-optimization.scm │ ├── test-interp-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── test-interp-inlined-prims-with-real-evalo-dispatch.scm │ ├── test-interp-inlined-prims.scm │ └── test-interp-old-style.scm └── hangout-7 │ ├── EXPLANATION.md │ ├── exit.scm │ ├── fastest-bench-map.txt │ ├── interp-fastest-fixed-application-optimization.scm │ ├── interp-fastest-fixed.scm │ ├── interp-fastest.scm │ ├── interp-inlined-prims-with-dummy-evalo-dispatch-application-optimization.scm │ ├── interp-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── interp-inlined-prims-with-real-evalo-dispatch.scm │ ├── interp-inlined-prims.scm │ ├── interp-old-style.scm │ ├── mk-vicare.scm │ ├── mk.rkt │ ├── mk.scm │ ├── test-check.scm │ ├── test-interp-fastest-fixed-application-optimization.scm │ ├── test-interp-fastest-fixed.scm │ ├── test-interp-fastest.scm │ ├── test-interp-inlined-prims-with-dummy-evalo-dispatch-application-optimization.scm │ ├── test-interp-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── test-interp-inlined-prims-with-real-evalo-dispatch.scm │ ├── test-interp-inlined-prims.scm │ └── test-interp-old-style.scm └── intro-hangouts ├── intro-hangout-2 ├── intro-hangout-2.scm └── pmatch.scm ├── intro-hangout-3 ├── transcript-part1.scm └── transcript-part2.scm ├── intro-hangout-4 ├── intro-hangout-4.scm └── pmatch.scm ├── intro-hangout-5 ├── first-order-interp.scm ├── interp-dynamic-scope.scm ├── interp-rep-ind.scm ├── intro-hangout-5.scm └── pmatch.scm ├── intro-hangout-6 ├── first-order-interp.scm └── pmatch.scm ├── intro-hangout-7 ├── faster-miniKanren │ ├── ==-tests.scm │ ├── LICENSE │ ├── README.md │ ├── absento-closure-tests.scm │ ├── absento-tests.scm │ ├── conj.scm │ ├── disequality-tests.scm │ ├── eval.scm │ ├── full-interp-bigram.scm │ ├── full-interp-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── full-interp-inlined-prims-with-real-evalo-dispatch.scm │ ├── full-interp-inlined-prims.scm │ ├── full-interp.scm │ ├── interp-uber-tests-bigram.scm │ ├── interp-uber-tests-inlined-prims-with-dummy-evalo-dispatch.scm │ ├── interp-uber-tests-inlined-prims-with-real-evalo-dispatch.scm │ ├── interp-uber-tests-inlined-prims.scm │ ├── interp-uber-tests.scm │ ├── matche.rkt │ ├── matche.scm │ ├── mk-vicare.scm │ ├── mk.rkt │ ├── mk.scm │ ├── numbero-tests.scm │ ├── numbers.scm │ ├── simple-interp.scm │ ├── sort.scm │ ├── symbolo-numbero-tests.scm │ ├── symbolo-tests.scm │ ├── test-all.scm │ ├── test-check.scm │ ├── test-infer.scm │ ├── test-numbers.scm │ ├── test-quines.scm │ └── test-simple-interp.scm ├── hangout-7.scm ├── trans.scm └── trans2.scm ├── intro-hangout-8 └── hangout-8.scm └── intro-hangout-9 ├── faster-miniKanren ├── ==-tests.scm ├── LICENSE ├── README.md ├── absento-closure-tests.scm ├── absento-tests.scm ├── conj.scm ├── disequality-tests.scm ├── eval.scm ├── full-interp-bigram.scm ├── full-interp-inlined-prims-with-dummy-evalo-dispatch.scm ├── full-interp-inlined-prims-with-real-evalo-dispatch.scm ├── full-interp-inlined-prims.scm ├── full-interp.scm ├── interp-uber-tests-bigram.scm ├── interp-uber-tests-inlined-prims-with-dummy-evalo-dispatch.scm ├── interp-uber-tests-inlined-prims-with-real-evalo-dispatch.scm ├── interp-uber-tests-inlined-prims.scm ├── interp-uber-tests.scm ├── matche.rkt ├── matche.scm ├── mk-vicare.scm ├── mk.rkt ├── mk.scm ├── numbero-tests.scm ├── numbers.scm ├── simple-interp.scm ├── sort.scm ├── symbolo-numbero-tests.scm ├── symbolo-tests.scm ├── test-all.scm ├── test-check.scm ├── test-infer.scm ├── test-numbers.scm ├── test-quines.scm └── test-simple-interp.scm ├── hangout-9.scm └── trans.scm /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 William E. Byrd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # miniKanren-hangout-summaries 2 | Summaries of intro and advanced miniKanren hangout series. * Add one or two more explanatory sentences * 3 | 4 | ## Quick Links 5 | * [miniKanren website](http://minikanren.org/) 6 | * [miniKanren Google Group](https://groups.google.com/forum/#!forum/minikanren) 7 | * [miniKanren Uncourse Google Group](https://groups.google.com/forum/#!forum/minikanren-uncourse) 8 | * [Barliman Google Group](https://groups.google.com/forum/#!forum/barliman-editor) 9 | 10 | * [faster-miniKanren GitHub repo](https://github.com/michaelballantyne/faster-miniKanren) 11 | * [microKanren (also known as muKanren) GitHub repo](https://github.com/jasonhemann/microKanren) 12 | * [Barliman GitHub repo](https://github.com/webyrd/Barliman) 13 | 14 | ## Current Schedule 15 | * Intro: Saturdays, 3PM EST 16 | * Advanced: Sundays, 3PM EST 17 | 18 | ## Planning/Agenda for next hangout: 19 | ### Advanced (2017-05-07) 20 | * Continue optimizing the interpreter from hangout #6. 21 | ### Intro (2017-05-06) 22 | * Will is travelling--no hangout! 23 | 24 | ## Recaps of Prior Hangouts 25 | 26 | ### Advanced #6 (2017-04-30) 27 | * Youtube link: https://www.youtube.com/watch?v=4cDsePg5c3k 28 | * Topics:Lots of live coding. We fix an error in the relational interpreter, try to understand why a version of the relational interpreter is slow when handling recursion, and combine one of the Barliman optimizations with the n-gram relational interpreter. The resulting interpreter seems faster than Barliman, for at least some synthesis problems. 29 | * Code: https://github.com/webyrd/miniKanren-hangout-summaries/tree/master/code/advanced-hangouts/hangout-6 30 | 31 | ### Advanced #5 (2017-04-23) 32 | * Youtube link: https://www.youtube.com/watch?v=KTS5XYeZZW4 33 | * Topics: Will proposes an idea for handling arithmetic in Barliman, which gets shot down, but leads to a discussion of different ways the educational version of Barliman might be able to perform arithmetic. Orchid describes how to efficiently color maps using a combination of Scheme and miniKanren (https://orchid-hybrid-2.github.io/), based on an article by John McCarthy (http://www-formal.stanford.edu/jmc/coloring/coloring.html). 34 | 35 | ### Advanced #4 (2017-04-16) 36 | * Youtube link: https://www.youtube.com/watch?v=u3xjelzmC20 37 | * Topics: Luke describes how we has extended a Python version of miniKanren with interval arithmetic constraints to solve problems in naval architecture/ship hull design. Will describes experiments he made this week (https://github.com/webyrd/n-grams-for-synthesis) that might improve performance of the relational interpreter by guiding the search based on what real-world Scheme programs look like. 38 | 39 | ### Advanced #3 (2017-04-09) 40 | * Youtube link: https://www.youtube.com/watch?v=OfrR1pm8q6g 41 | * Topics: Greg walks through the improvements and optimizations that radically sped up the relational interpreter used by Barliman. 42 | 43 | ### Advanced #2 (2017-04-02) 44 | * Youtube link: https://www.youtube.com/watch?v=B7Tglu-1_NQ 45 | * ~3-40 minutes, Michael1 asks if it might be possible to use mk to facilitate network configuration. Various attempts are made to formulate more precisely what this might mean 46 | * Related Links: http://www.cs.cornell.edu/~jnfoster/papers/frenetic-netkat.pdf 47 | * ~40-80 minutes, Will describes a tricky problem with the current Barliman, in which the user has made a "clear" mistake, Barliman, instead of complaining, cleverly finds a way to code around the issue -- not necessarily the message one want to put across in a pedagogic setting. 48 | * ~80-end, Michael2 presents a few diagrams that help visualize how mk progresses through the search space. Nehal gives this "two thumbs up!" 49 | * Related Links: Rose asks Michael2 where in the mk implementation this search behavior is created, Michael2 says look here: 50 | * https://github.com/miniKanren/simple-miniKanren/blob/master/mk.scm#L201 51 | * https://github.com/miniKanren/simple-miniKanren/blob/master/mk.scm#L178 52 | 53 | ### Advanced #1 (2017-03-26) 54 | * Youtube link: https://www.youtube.com/watch?v=QZaTB92NKHM 55 | * Topics: Quick Barliman overview, implementation of faster-miniKanren (https://github.com/michaelballantyne/faster-miniKanren), and more! 56 | 57 | ### Intro #6 (2017-04-29) 58 | * Youtube link: https://www.youtube.com/watch?v=Q1BH1L6nrt8 59 | * Topics: With special guest, Dan Friedman! Lots of live coding. We add 'letrec' to our interpreter, using the "half-closures" implementation technique. We run into a few "happy accidents" along the way. 60 | * Code: https://github.com/webyrd/miniKanren-hangout-summaries/tree/master/code/intro-hangouts/intro-hangout-6 61 | 62 | ### Intro #5 (2017-04-22) 63 | * Youtube link: https://www.youtube.com/watch?v=2eYPZ5ztTUw 64 | * Topics: Higher-order Scheme interpreter, call-by-value, lexical scope vs. dynamic scope, representation independence. 65 | * Code: https://github.com/webyrd/miniKanren-hangout-summaries/tree/master/code/intro-hangouts/intro-hangout-5 66 | 67 | ### Intro #4 (2017-04-15) 68 | * Youtube link: https://www.youtube.com/watch?v=oV-5az3yNxA 69 | * Topics: Environments, writing a simple test macro, writing a simple environment-passing interpreter for a subset of Scheme, creating a recursive function without using 'define' or 'letrec'. 70 | * Code: https://github.com/webyrd/miniKanren-hangout-summaries/tree/master/code/intro-hangouts/intro-hangout-4 71 | 72 | ### Intro #3 (2017-04-08) 73 | * Note: Will's internet went down during the end of hangout, so this hangout is recorded in two parts (the second part is short) 74 | * Youtube links: https://www.youtube.com/edit?video_id=8-HUiRt6nJw (Part 1), https://www.youtube.com/edit?video_id=Of5sdH_ZAQs (Part 2) 75 | * Topics: Answering questions from the previous hangout, a unexpected lesson how to learn about the details of a programming language (a happy accident/learning opportunity), more examples of Scheme macros, lexical scope and shadowing. 76 | * Code transcripts: https://github.com/webyrd/miniKanren-hangout-summaries/blob/master/code/intro-hangouts/intro-hangout-3/transcript-part1.scm (Part 1), https://github.com/webyrd/miniKanren-hangout-summaries/blob/master/code/intro-hangouts/intro-hangout-3/transcript-part2.scm (Part 2) 77 | 78 | ### Intro #2 (2017-04-01) 79 | * Youtube link: https://www.youtube.com/watch?v=s8d8uhU-_SY 80 | * Topics: More examples of recursion in Scheme, deep recursion over nested lists, brief description of Scheme macros, a pattern matching macro for Scheme, parsing lambda calculus expressions. 81 | * Code: https://github.com/webyrd/miniKanren-hangout-summaries/tree/master/code/intro-hangouts/intro-hangout-2 82 | 83 | ### Intro #1 (2017-03-25) 84 | * Youtube link: https://www.youtube.com/watch?v=a5p8DPbaokE 85 | * Topics: basic Scheme, lists and pairs, conditional expressions, definitions, recursion, how to think recursively. 86 | 87 | ## Meta 88 | * Meta will be moved elsewhere 89 | * You are encouraged to ask for push permission. If you are considering following this repo, just ask for push bits instead. 90 | * Just scaffold out content. Either you or someone else will fill in the details / cleanup typos later. 91 | * If you like, make edits directly via the github webpage interface. 92 | * Add the newest recaps at the top of the list 93 | * Add annotations of any other mk videos/events, not just the hangous e.g. clojure conferences etc. 94 | * Thanks! 95 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-6/EXPLANATION.md: -------------------------------------------------------------------------------- 1 | This directory contains several versions of the 'full-interp.scm' relational interpreter from 'faster-mk' (https://github.com/michaelballantyne/faster-miniKanren/blob/master/full-interp.scm), along with the implementation of 'faster-mk'. The modified versions of the interpreter are intended to explore the tradeoffs in ordering the 'conde' clauses in the interpreter by the context of the current expression to be evaluated or synthesized (for example, if the current context is the body of a 'lambda' expression, then perhaps an 'if' expression would be likely. 2 | 3 | The intent is to order the 'conde' clauses based on the bigram results in the main directory. 4 | 5 | The interpreters, in the order I modified them: 6 | 7 | * interp-old-style.scm -- the original relational interpreter from the 'faster-mk' repository, corresponding to https://github.com/michaelballantyne/faster-miniKanren/blob/master/full-interp.scm There is one, fixed ordering of 'conde' clauses in this interpreter, and the interpreter does not pass around the context of the current expression. 8 | * interp-inlined-prims.scm -- same as 'interp-old-style.scm', except that all primitives have been "inlined" into the main 'conde' of 'eval-expo'. There is one, fixed ordering of 'conde' clauses in this interpreter, and the interpreter does not pass around the context of the current expression. The intent of this interpreter is to prepare for the next transformation (dummy evalo dispatch), and to be able to benchmark the effect of inlining primitives without reording the clauses. This interpreter appears significantly slower than 'interp-old-style.scm' on most or all of the benchmarks. 9 | * interp-inlined-prims-with-dummy-evalo-dispatch.scm -- same as 'interp-inlined-prims.scm', except that 'eval-expo' has been replaced by 'make-eval-expo', which dispatches to a function that performs the work of the old 'eval-expo' based on the context of the current expression. This is a "dummy" dispatch: the dispatch tests are made, but there is only one function with a fixed 'conde' ordering that is always dispatched to. The intent of this interpreter is to prepare for the next transformation (interp-inlined-prims-with-real-evalo-dispatch), and to be able to benchmark the effect of dispatch to a helper function containing the main 'conde' for the interpreter. 10 | * interp-inlined-prims-with-real-evalo-dispatch.scm -- same as 'interp-inlined-prims.scm', except that 'make-eval-expo' now makes a choice between different helper functions with different 'conde' orderings, based on the context of the current expression. For almost all contexts the interpreter dispatches to 'eval-expo-with-default-ordering', which uses the same goal ordering of 'interp-inlined-prims.scm' (which in turn is based on the goal ordering of 'interp-old-style.scm'. However, this interpreter dispatches to 'eval-expo-if-test-ordering' when the current expression is the test of an 'if' expression, and this change alone appears to radically speed up some of the benchmarks without harming the other benchmarks noticably. For example, test "append-10" went from taking ~30 seconds to taking ~40 milliseconds. 11 | 12 | To run these tests, and see the timings of the benchmarks, load the appropriate test file in Chez Scheme. The most interesting contrast is between 'test-interp-old-style.scm' and 'test-interp-inlined-prims-with-real-evalo-dispatch.scm', especially in synthesis tests such as 'append-9', 'append-10', and 'append-11'. (Some of these tests are commented out in interpreters other than 'interp-inlined-prims-with-real-evalo-dispatch.scm'. This is because the tests did not return after I ran them for a while (30 seconds or more).) 13 | 14 | The interpreter 'interp-fastest.scm' is a "less dumb" version of 'interp-inlined-prims-with-real-evalo-dispatch.scm' that makes obvious optimizations (such as multi-argument application should come before variadic application, even though the n-grams program does not yet gather this information). 15 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-6/fastest-bench-map.txt: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.4.1 2 | Copyright 1984-2016 Cisco Systems, Inc. 3 | 4 | > (load "test-interp-fastest.scm") 5 | Testing "map-0" 6 | (time (test "map-0" ...)) 7 | 1 collection 8 | 0.012672000s elapsed cpu time, including 0.000222000s collecting 9 | 0.012800000s elapsed real time, including 0.000226000s collecting 10 | 7679456 bytes allocated, including 8320112 bytes reclaimed 11 | Testing "map-1" 12 | (time (test "map-1" ...)) 13 | 2 collections 14 | 0.034069000s elapsed cpu time, including 0.000408000s collecting 15 | 0.034797000s elapsed real time, including 0.000424000s collecting 16 | 20601104 bytes allocated, including 17158224 bytes reclaimed 17 | Testing "map-2" 18 | (time (test "map-2" ...)) 19 | 68 collections 20 | 1.175691000s elapsed cpu time, including 0.046238000s collecting 21 | 1.180967000s elapsed real time, including 0.046606000s collecting 22 | 572896848 bytes allocated, including 571918720 bytes reclaimed 23 | Testing "map-3" 24 | (time (test "map-3" ...)) 25 | 5 collections 26 | 0.066701000s elapsed cpu time, including 0.001000000s collecting 27 | 0.068242000s elapsed real time, including 0.001021000s collecting 28 | 43945088 bytes allocated, including 42030112 bytes reclaimed 29 | Testing "map-4" 30 | (time (test "map-4" ...)) 31 | 10 collections 32 | 0.137789000s elapsed cpu time, including 0.002532000s collecting 33 | 0.138867000s elapsed real time, including 0.002592000s collecting 34 | 80799248 bytes allocated, including 84255600 bytes reclaimed 35 | Testing "map-5" 36 | (time (test "map-5" ...)) 37 | 33 collections 38 | 0.474754000s elapsed cpu time, including 0.012721000s collecting 39 | 0.478544000s elapsed real time, including 0.012909000s collecting 40 | 276033328 bytes allocated, including 279668192 bytes reclaimed 41 | Testing "map-7" 42 | (time (test "map-7" ...)) 43 | 530 collections 44 | 11.483030000s elapsed cpu time, including 0.990284000s collecting 45 | 11.531676000s elapsed real time, including 0.996676000s collecting 46 | 4461232864 bytes allocated, including 4412527200 bytes reclaimed 47 | Testing "map-8" 48 | (time (test "map-8" ...)) 49 | 3 collections 50 | 0.040403000s elapsed cpu time, including 0.000664000s collecting 51 | 0.041184000s elapsed real time, including 0.000690000s collecting 52 | 22745568 bytes allocated, including 26400816 bytes reclaimed 53 | Testing "map-9" 54 | (time (test "map-9" ...)) 55 | 6 collections 56 | 0.089189000s elapsed cpu time, including 0.001784000s collecting 57 | 0.090343000s elapsed real time, including 0.002249000s collecting 58 | 53486896 bytes allocated, including 50358672 bytes reclaimed 59 | Testing "map-10" 60 | (time (test "map-10" ...)) 61 | 11 collections 62 | 0.146212000s elapsed cpu time, including 0.003543000s collecting 63 | 0.148651000s elapsed real time, including 0.003689000s collecting 64 | 85209136 bytes allocated, including 92172000 bytes reclaimed 65 | Testing "map-11" 66 | (time (test "map-11" ...)) 67 | 10 collections 68 | 0.148326000s elapsed cpu time, including 0.005685000s collecting 69 | 0.149646000s elapsed real time, including 0.005758000s collecting 70 | 85850752 bytes allocated, including 90892464 bytes reclaimed 71 | Testing "map-12" 72 | (time (test "map-12" ...)) 73 | 17 collections 74 | 0.259862000s elapsed cpu time, including 0.016447000s collecting 75 | 0.262394000s elapsed real time, including 0.016536000s collecting 76 | 140912304 bytes allocated, including 140901488 bytes reclaimed 77 | Testing "map-13" 78 | (time (test "map-13" ...)) 79 | 237 collections 80 | 5.305654000s elapsed cpu time, including 0.625921000s collecting 81 | 5.347623000s elapsed real time, including 0.632020000s collecting 82 | 1998181488 bytes allocated, including 2001684560 bytes reclaimed 83 | Testing "map-14" 84 | (time (test "map-14" ...)) 85 | 250 collections 86 | 7.626401000s elapsed cpu time, including 1.142144000s collecting 87 | 7.725536000s elapsed real time, including 1.159115000s collecting 88 | 2113710624 bytes allocated, including 2065329376 bytes reclaimed 89 | Testing "map-15" 90 | (time (test "map-15" ...)) 91 | 879 collections 92 | 28.634457000s elapsed cpu time, including 4.007304000s collecting 93 | 28.946495000s elapsed real time, including 4.054065000s collecting 94 | 7407461792 bytes allocated, including 7397804224 bytes reclaimed 95 | Testing "map-16" 96 | (time (test "map-16" ...)) 97 | 984 collections 98 | 25.144686000s elapsed cpu time, including 3.587469000s collecting 99 | 25.312438000s elapsed real time, including 3.621671000s collecting 100 | 8288730176 bytes allocated, including 8309414960 bytes reclaimed 101 | Testing "map-17" 102 | (time (test "map-17" ...)) 103 | 940 collections 104 | 75.634515000s elapsed cpu time, including 2.276380000s collecting 105 | 76.052347000s elapsed real time, including 2.291535000s collecting 106 | 7922133680 bytes allocated, including 7904476048 bytes reclaimed 107 | Testing "map-18" 108 | (time (test "map-18" ...)) 109 | 940 collections 110 | 75.639920000s elapsed cpu time, including 2.281725000s collecting 111 | 76.075915000s elapsed real time, including 2.300328000s collecting 112 | 7917608928 bytes allocated, including 7931929360 bytes reclaimed 113 | Testing "map-19" 114 | C-c C-cbreak> r 115 | > -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-6/mk-vicare.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | 6 | ; Trie implementation, due to Abdulaziz Ghuloum. Used for substitution 7 | ; and constraint store. 8 | 9 | ;;; subst ::= (empty) 10 | ;;; | (node even odd) 11 | ;;; | (data idx val) 12 | 13 | (define-record-type node (fields e o)) 14 | 15 | (define-record-type data (fields idx val)) 16 | 17 | (define shift (lambda (n) (fxsra n 1))) 18 | 19 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 20 | 21 | ;;; interface 22 | 23 | (define t:size 24 | (lambda (x) (t:aux:size x))) 25 | 26 | (define t:bind 27 | (lambda (xi v s) 28 | (unless (and (fixnum? xi) (>= xi 0)) 29 | (error 't:bind "index must be a fixnum, got ~s" xi)) 30 | (t:aux:bind xi v s))) 31 | 32 | (define t:unbind 33 | (lambda (xi s) 34 | (unless (and (fixnum? xi) (>= xi 0)) 35 | (error 't:unbind "index must be a fixnum, got ~s" xi)) 36 | (t:aux:unbind xi s))) 37 | 38 | (define t:lookup 39 | (lambda (xi s) 40 | (unless (and (fixnum? xi) (>= xi 0)) 41 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 42 | (t:aux:lookup xi s))) 43 | 44 | (define t:binding-value 45 | (lambda (s) 46 | (unless (data? s) 47 | (error 't:binding-value "not a binding ~s" s)) 48 | (data-val s))) 49 | 50 | ;;; helpers 51 | 52 | (define t:aux:push 53 | (lambda (xi vi xj vj) 54 | (if (fxeven? xi) 55 | (if (fxeven? xj) 56 | (make-node (t:aux:push (shift xi) vi (shift xj) vj) '()) 57 | (make-node (make-data (shift xi) vi) (make-data (shift xj) vj))) 58 | (if (fxeven? xj) 59 | (make-node (make-data (shift xj) vj) (make-data (shift xi) vi)) 60 | (make-node '() (t:aux:push (shift xi) vi (shift xj) vj)))))) 61 | 62 | (define t:aux:bind 63 | (lambda (xi vi s*) 64 | (cond 65 | [(node? s*) 66 | (if (fxeven? xi) 67 | (make-node (t:aux:bind (shift xi) vi (node-e s*)) (node-o s*)) 68 | (make-node (node-e s*) (t:aux:bind (shift xi) vi (node-o s*))))] 69 | [(data? s*) 70 | (let ([xj (data-idx s*)] [vj (data-val s*)]) 71 | (if (fx= xi xj) 72 | (make-data xi vi) 73 | (t:aux:push xi vi xj vj)))] 74 | [else (make-data xi vi)]))) 75 | 76 | (define t:aux:lookup 77 | (lambda (xi s*) 78 | (cond 79 | [(node? s*) 80 | (if (fxeven? xi) 81 | (t:aux:lookup (shift xi) (node-e s*)) 82 | (t:aux:lookup (shift xi) (node-o s*)))] 83 | [(data? s*) 84 | (if (fx= (data-idx s*) xi) 85 | s* 86 | #f)] 87 | [else #f]))) 88 | 89 | (define t:aux:size 90 | (lambda (s*) 91 | (cond 92 | [(node? s*) (fx+ (t:aux:size (node-e s*)) (t:aux:size (node-o s*)))] 93 | [(data? s*) 1] 94 | [else 0]))) 95 | 96 | (define t:aux:cons^ 97 | (lambda (e o) 98 | (cond 99 | [(or (node? e) (node? o)) (make-node e o)] 100 | [(data? e) 101 | (make-data (unshift (data-idx e) 0) (data-val e))] 102 | [(data? o) 103 | (make-data (unshift (data-idx o) 1) (data-val o))] 104 | [else '()]))) 105 | 106 | (define t:aux:unbind 107 | (lambda (xi s*) 108 | (cond 109 | [(node? s*) 110 | (if (fxeven? xi) 111 | (t:aux:cons^ (t:aux:unbind (shift xi) (node-e s*)) (node-o s*)) 112 | (t:aux:cons^ (node-e s*) (t:aux:unbind (shift xi) (node-o s*))))] 113 | [(and (data? s*) (fx= (data-idx s*) xi)) '()] 114 | [else s*]))) 115 | 116 | 117 | ; Substitution representation 118 | 119 | (define empty-subst-map '()) 120 | 121 | (define subst-map-length t:size) 122 | 123 | ; Returns #f if not found, or a pair of u and the result of the lookup. 124 | ; This distinguishes between #f indicating absence and being the result. 125 | (define subst-map-lookup 126 | (lambda (u S) 127 | (let ((res (t:lookup (var-idx u) S))) 128 | (if res 129 | (data-val res) 130 | unbound)))) 131 | 132 | (define (subst-map-add S var val) 133 | (t:bind (var-idx var) val S)) 134 | 135 | (define subst-map-eq? eq?) 136 | 137 | 138 | ; Alternative (unused) substitution representation, using alists. 139 | ; Performance with the tries is usually about the same and 140 | ; can be much better for huge substitutions. 141 | 142 | #| 143 | (define empty-subst-map '()) 144 | 145 | (define subst-map-length length) 146 | 147 | ; Returns #f if not found, or a pair of u and the result of the lookup. 148 | ; This distinguishes between #f indicating absence and being the result. 149 | (define subst-map-lookup 150 | (lambda (u S) 151 | (let ((res (assq u S))) 152 | (if res 153 | (cdr res) 154 | unbound)))) 155 | 156 | (define (subst-map-add S var val) 157 | (cons (cons var val) S)) 158 | 159 | (define subst-map-eq? eq?) 160 | |# 161 | 162 | 163 | ; Constraint store representation 164 | 165 | (define empty-C '()) 166 | 167 | (define set-c 168 | (lambda (v c st) 169 | (state (state-S st) (t:bind (var-idx v) c (state-C st))))) 170 | 171 | (define lookup-c 172 | (lambda (v st) 173 | (let ((res (t:lookup (var-idx v) (state-C st)))) 174 | (if res 175 | (data-val res) 176 | empty-c)))) 177 | 178 | ; t:unbind either is buggy or doesn't do what I would expect, so 179 | ; I implement remove by setting the value to the empty constraint record. 180 | (define remove-c 181 | (lambda (v st) 182 | (let ((res (t:bind (var-idx v) empty-c (state-C st)))) 183 | (state (state-S st) res)))) 184 | 185 | 186 | ; Misc. missing functions 187 | 188 | (define (remove-duplicates l) 189 | (cond ((null? l) 190 | '()) 191 | ((member (car l) (cdr l)) 192 | (remove-duplicates (cdr l))) 193 | (else 194 | (cons (car l) (remove-duplicates (cdr l)))))) 195 | 196 | (define (foldl f init seq) 197 | (if (null? seq) 198 | init 199 | (foldl f 200 | (f (car seq) init) 201 | (cdr seq)))) 202 | 203 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-6/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide run run* 4 | == =/= 5 | fresh 6 | conde 7 | symbolo numbero 8 | absento 9 | (all-defined-out)) 10 | 11 | ;; extra stuff for racket 12 | ;; due mostly to samth 13 | (define (list-sort f l) (sort l f)) 14 | 15 | (define (remp f l) (filter-not f l)) 16 | 17 | (define (call-with-string-output-port f) 18 | (define p (open-output-string)) 19 | (f p) 20 | (get-output-string p)) 21 | 22 | (define (exists f l) (ormap f l)) 23 | 24 | (define for-all andmap) 25 | 26 | (define (find f l) 27 | (cond [(memf f l) => car] [else #f])) 28 | 29 | (define memp memf) 30 | 31 | (define (var*? v) (var? (car v))) 32 | 33 | 34 | ; Substitution representation 35 | 36 | (define empty-subst-map (hasheq)) 37 | 38 | (define subst-map-length hash-count) 39 | 40 | ; Returns #f if not found, or a pair of u and the result of the lookup. 41 | ; This distinguishes between #f indicating absence and being the result. 42 | (define subst-map-lookup 43 | (lambda (u S) 44 | (hash-ref S u unbound))) 45 | 46 | (define (subst-map-add S var val) 47 | (hash-set S var val)) 48 | 49 | (define subst-map-eq? eq?) 50 | 51 | 52 | ; Constraint store representation 53 | 54 | (define empty-C (hasheq)) 55 | 56 | (define set-c 57 | (lambda (v c st) 58 | (state (state-S st) (hash-set (state-C st) v c)))) 59 | 60 | (define lookup-c 61 | (lambda (v st) 62 | (hash-ref (state-C st) v empty-c))) 63 | 64 | (define remove-c 65 | (lambda (v st) 66 | (state (state-S st) (hash-remove (state-C st) v)))) 67 | 68 | 69 | (include "mk.scm") 70 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-6/test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/EXPLANATION.md: -------------------------------------------------------------------------------- 1 | This directory contains several versions of the 'full-interp.scm' relational interpreter from 'faster-mk' (https://github.com/michaelballantyne/faster-miniKanren/blob/master/full-interp.scm), along with the implementation of 'faster-mk'. The modified versions of the interpreter are intended to explore the tradeoffs in ordering the 'conde' clauses in the interpreter by the context of the current expression to be evaluated or synthesized (for example, if the current context is the body of a 'lambda' expression, then perhaps an 'if' expression would be likely. 2 | 3 | The intent is to order the 'conde' clauses based on the bigram results in the main directory. 4 | 5 | The interpreters, in the order I modified them: 6 | 7 | * interp-old-style.scm -- the original relational interpreter from the 'faster-mk' repository, corresponding to https://github.com/michaelballantyne/faster-miniKanren/blob/master/full-interp.scm There is one, fixed ordering of 'conde' clauses in this interpreter, and the interpreter does not pass around the context of the current expression. 8 | * interp-inlined-prims.scm -- same as 'interp-old-style.scm', except that all primitives have been "inlined" into the main 'conde' of 'eval-expo'. There is one, fixed ordering of 'conde' clauses in this interpreter, and the interpreter does not pass around the context of the current expression. The intent of this interpreter is to prepare for the next transformation (dummy evalo dispatch), and to be able to benchmark the effect of inlining primitives without reording the clauses. This interpreter appears significantly slower than 'interp-old-style.scm' on most or all of the benchmarks. 9 | * interp-inlined-prims-with-dummy-evalo-dispatch.scm -- same as 'interp-inlined-prims.scm', except that 'eval-expo' has been replaced by 'make-eval-expo', which dispatches to a function that performs the work of the old 'eval-expo' based on the context of the current expression. This is a "dummy" dispatch: the dispatch tests are made, but there is only one function with a fixed 'conde' ordering that is always dispatched to. The intent of this interpreter is to prepare for the next transformation (interp-inlined-prims-with-real-evalo-dispatch), and to be able to benchmark the effect of dispatch to a helper function containing the main 'conde' for the interpreter. 10 | * interp-inlined-prims-with-real-evalo-dispatch.scm -- same as 'interp-inlined-prims.scm', except that 'make-eval-expo' now makes a choice between different helper functions with different 'conde' orderings, based on the context of the current expression. For almost all contexts the interpreter dispatches to 'eval-expo-with-default-ordering', which uses the same goal ordering of 'interp-inlined-prims.scm' (which in turn is based on the goal ordering of 'interp-old-style.scm'. However, this interpreter dispatches to 'eval-expo-if-test-ordering' when the current expression is the test of an 'if' expression, and this change alone appears to radically speed up some of the benchmarks without harming the other benchmarks noticably. For example, test "append-10" went from taking ~30 seconds to taking ~40 milliseconds. 11 | 12 | To run these tests, and see the timings of the benchmarks, load the appropriate test file in Chez Scheme. The most interesting contrast is between 'test-interp-old-style.scm' and 'test-interp-inlined-prims-with-real-evalo-dispatch.scm', especially in synthesis tests such as 'append-9', 'append-10', and 'append-11'. (Some of these tests are commented out in interpreters other than 'interp-inlined-prims-with-real-evalo-dispatch.scm'. This is because the tests did not return after I ran them for a while (30 seconds or more).) 13 | 14 | The interpreter 'interp-fastest.scm' is a "less dumb" version of 'interp-inlined-prims-with-real-evalo-dispatch.scm' that makes obvious optimizations (such as multi-argument application should come before variadic application, even though the n-grams program does not yet gather this information). 15 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/exit.scm: -------------------------------------------------------------------------------- 1 | (exit) 2 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/fastest-bench-map.txt: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.4.1 2 | Copyright 1984-2016 Cisco Systems, Inc. 3 | 4 | > (load "test-interp-fastest.scm") 5 | Testing "map-0" 6 | (time (test "map-0" ...)) 7 | 1 collection 8 | 0.012672000s elapsed cpu time, including 0.000222000s collecting 9 | 0.012800000s elapsed real time, including 0.000226000s collecting 10 | 7679456 bytes allocated, including 8320112 bytes reclaimed 11 | Testing "map-1" 12 | (time (test "map-1" ...)) 13 | 2 collections 14 | 0.034069000s elapsed cpu time, including 0.000408000s collecting 15 | 0.034797000s elapsed real time, including 0.000424000s collecting 16 | 20601104 bytes allocated, including 17158224 bytes reclaimed 17 | Testing "map-2" 18 | (time (test "map-2" ...)) 19 | 68 collections 20 | 1.175691000s elapsed cpu time, including 0.046238000s collecting 21 | 1.180967000s elapsed real time, including 0.046606000s collecting 22 | 572896848 bytes allocated, including 571918720 bytes reclaimed 23 | Testing "map-3" 24 | (time (test "map-3" ...)) 25 | 5 collections 26 | 0.066701000s elapsed cpu time, including 0.001000000s collecting 27 | 0.068242000s elapsed real time, including 0.001021000s collecting 28 | 43945088 bytes allocated, including 42030112 bytes reclaimed 29 | Testing "map-4" 30 | (time (test "map-4" ...)) 31 | 10 collections 32 | 0.137789000s elapsed cpu time, including 0.002532000s collecting 33 | 0.138867000s elapsed real time, including 0.002592000s collecting 34 | 80799248 bytes allocated, including 84255600 bytes reclaimed 35 | Testing "map-5" 36 | (time (test "map-5" ...)) 37 | 33 collections 38 | 0.474754000s elapsed cpu time, including 0.012721000s collecting 39 | 0.478544000s elapsed real time, including 0.012909000s collecting 40 | 276033328 bytes allocated, including 279668192 bytes reclaimed 41 | Testing "map-7" 42 | (time (test "map-7" ...)) 43 | 530 collections 44 | 11.483030000s elapsed cpu time, including 0.990284000s collecting 45 | 11.531676000s elapsed real time, including 0.996676000s collecting 46 | 4461232864 bytes allocated, including 4412527200 bytes reclaimed 47 | Testing "map-8" 48 | (time (test "map-8" ...)) 49 | 3 collections 50 | 0.040403000s elapsed cpu time, including 0.000664000s collecting 51 | 0.041184000s elapsed real time, including 0.000690000s collecting 52 | 22745568 bytes allocated, including 26400816 bytes reclaimed 53 | Testing "map-9" 54 | (time (test "map-9" ...)) 55 | 6 collections 56 | 0.089189000s elapsed cpu time, including 0.001784000s collecting 57 | 0.090343000s elapsed real time, including 0.002249000s collecting 58 | 53486896 bytes allocated, including 50358672 bytes reclaimed 59 | Testing "map-10" 60 | (time (test "map-10" ...)) 61 | 11 collections 62 | 0.146212000s elapsed cpu time, including 0.003543000s collecting 63 | 0.148651000s elapsed real time, including 0.003689000s collecting 64 | 85209136 bytes allocated, including 92172000 bytes reclaimed 65 | Testing "map-11" 66 | (time (test "map-11" ...)) 67 | 10 collections 68 | 0.148326000s elapsed cpu time, including 0.005685000s collecting 69 | 0.149646000s elapsed real time, including 0.005758000s collecting 70 | 85850752 bytes allocated, including 90892464 bytes reclaimed 71 | Testing "map-12" 72 | (time (test "map-12" ...)) 73 | 17 collections 74 | 0.259862000s elapsed cpu time, including 0.016447000s collecting 75 | 0.262394000s elapsed real time, including 0.016536000s collecting 76 | 140912304 bytes allocated, including 140901488 bytes reclaimed 77 | Testing "map-13" 78 | (time (test "map-13" ...)) 79 | 237 collections 80 | 5.305654000s elapsed cpu time, including 0.625921000s collecting 81 | 5.347623000s elapsed real time, including 0.632020000s collecting 82 | 1998181488 bytes allocated, including 2001684560 bytes reclaimed 83 | Testing "map-14" 84 | (time (test "map-14" ...)) 85 | 250 collections 86 | 7.626401000s elapsed cpu time, including 1.142144000s collecting 87 | 7.725536000s elapsed real time, including 1.159115000s collecting 88 | 2113710624 bytes allocated, including 2065329376 bytes reclaimed 89 | Testing "map-15" 90 | (time (test "map-15" ...)) 91 | 879 collections 92 | 28.634457000s elapsed cpu time, including 4.007304000s collecting 93 | 28.946495000s elapsed real time, including 4.054065000s collecting 94 | 7407461792 bytes allocated, including 7397804224 bytes reclaimed 95 | Testing "map-16" 96 | (time (test "map-16" ...)) 97 | 984 collections 98 | 25.144686000s elapsed cpu time, including 3.587469000s collecting 99 | 25.312438000s elapsed real time, including 3.621671000s collecting 100 | 8288730176 bytes allocated, including 8309414960 bytes reclaimed 101 | Testing "map-17" 102 | (time (test "map-17" ...)) 103 | 940 collections 104 | 75.634515000s elapsed cpu time, including 2.276380000s collecting 105 | 76.052347000s elapsed real time, including 2.291535000s collecting 106 | 7922133680 bytes allocated, including 7904476048 bytes reclaimed 107 | Testing "map-18" 108 | (time (test "map-18" ...)) 109 | 940 collections 110 | 75.639920000s elapsed cpu time, including 2.281725000s collecting 111 | 76.075915000s elapsed real time, including 2.300328000s collecting 112 | 7917608928 bytes allocated, including 7931929360 bytes reclaimed 113 | Testing "map-19" 114 | C-c C-cbreak> r 115 | > -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/mk-vicare.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | 6 | ; Old trie implementation, due to Abdulaziz Ghuloum. Used for substitution 7 | ; and constraint store. 8 | 9 | ;;; subst ::= (empty) 10 | ;;; | (node even odd) 11 | ;;; | (data idx val) 12 | 13 | (define-record-type node (fields e o)) 14 | 15 | (define-record-type data (fields idx val)) 16 | 17 | (define shift (lambda (n) (fxsra n 1))) 18 | 19 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 20 | 21 | 22 | ;; Switched to N-way Trie implementation to reduce depth 23 | 24 | (define shift-size 4) 25 | (define node-size (fxsll 1 shift-size)) 26 | (define local-mask (fx- node-size 1)) 27 | (define (shift-n xi) (fxsra xi shift-size)) 28 | (define (local-n xi) (fxand xi local-mask)) 29 | (define node-n? vector?) 30 | (define (node-n-new i0 v0) 31 | (define result (make-vector (fx+ i0 1) '())) 32 | (vector-set! result i0 v0) 33 | result) 34 | (define (node-n-get nd idx) 35 | (if (fx= xi 0)) 78 | (error 't:bind "index must be a fixnum, got ~s" xi)) 79 | (nwt:bind s xi v))) 80 | 81 | (define t:lookup 82 | (lambda (xi s) 83 | (unless (and (fixnum? xi) (>= xi 0)) 84 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 85 | (nwt:lookup s xi))) 86 | 87 | ;;; old interface 88 | 89 | ;(define t:size 90 | ;(lambda (x) (t:aux:size x))) 91 | 92 | ;(define t:bind 93 | ;(lambda (xi v s) 94 | ;(unless (and (fixnum? xi) (>= xi 0)) 95 | ;(error 't:bind "index must be a fixnum, got ~s" xi)) 96 | ;(t:aux:bind xi v s))) 97 | 98 | ;(define t:unbind 99 | ;(lambda (xi s) 100 | ;(unless (and (fixnum? xi) (>= xi 0)) 101 | ;(error 't:unbind "index must be a fixnum, got ~s" xi)) 102 | ;(t:aux:unbind xi s))) 103 | 104 | ;(define t:lookup 105 | ;(lambda (xi s) 106 | ;(unless (and (fixnum? xi) (>= xi 0)) 107 | ;(error 't:lookup "index must be a fixnum, got ~s" xi)) 108 | ;(t:aux:lookup xi s))) 109 | 110 | ;;; interface 111 | 112 | (define t:binding-value 113 | (lambda (s) 114 | (unless (data? s) 115 | (error 't:binding-value "not a binding ~s" s)) 116 | (data-val s))) 117 | 118 | ;;; helpers 119 | 120 | (define t:aux:push 121 | (lambda (xi vi xj vj) 122 | (if (fxeven? xi) 123 | (if (fxeven? xj) 124 | (make-node (t:aux:push (shift xi) vi (shift xj) vj) '()) 125 | (make-node (make-data (shift xi) vi) (make-data (shift xj) vj))) 126 | (if (fxeven? xj) 127 | (make-node (make-data (shift xj) vj) (make-data (shift xi) vi)) 128 | (make-node '() (t:aux:push (shift xi) vi (shift xj) vj)))))) 129 | 130 | (define t:aux:bind 131 | (lambda (xi vi s*) 132 | (cond 133 | [(node? s*) 134 | (if (fxeven? xi) 135 | (make-node (t:aux:bind (shift xi) vi (node-e s*)) (node-o s*)) 136 | (make-node (node-e s*) (t:aux:bind (shift xi) vi (node-o s*))))] 137 | [(data? s*) 138 | (let ([xj (data-idx s*)] [vj (data-val s*)]) 139 | (if (fx= xi xj) 140 | (make-data xi vi) 141 | (t:aux:push xi vi xj vj)))] 142 | [else (make-data xi vi)]))) 143 | 144 | (define t:aux:lookup 145 | (lambda (xi s*) 146 | (cond 147 | [(node? s*) 148 | (if (fxeven? xi) 149 | (t:aux:lookup (shift xi) (node-e s*)) 150 | (t:aux:lookup (shift xi) (node-o s*)))] 151 | [(data? s*) 152 | (if (fx= (data-idx s*) xi) 153 | s* 154 | #f)] 155 | [else #f]))) 156 | 157 | (define t:aux:size 158 | (lambda (s*) 159 | (cond 160 | [(node? s*) (fx+ (t:aux:size (node-e s*)) (t:aux:size (node-o s*)))] 161 | [(data? s*) 1] 162 | [else 0]))) 163 | 164 | (define t:aux:cons^ 165 | (lambda (e o) 166 | (cond 167 | [(or (node? e) (node? o)) (make-node e o)] 168 | [(data? e) 169 | (make-data (unshift (data-idx e) 0) (data-val e))] 170 | [(data? o) 171 | (make-data (unshift (data-idx o) 1) (data-val o))] 172 | [else '()]))) 173 | 174 | (define t:aux:unbind 175 | (lambda (xi s*) 176 | (cond 177 | [(node? s*) 178 | (if (fxeven? xi) 179 | (t:aux:cons^ (t:aux:unbind (shift xi) (node-e s*)) (node-o s*)) 180 | (t:aux:cons^ (node-e s*) (t:aux:unbind (shift xi) (node-o s*))))] 181 | [(and (data? s*) (fx= (data-idx s*) xi)) '()] 182 | [else s*]))) 183 | 184 | 185 | ; Substitution representation 186 | 187 | (define empty-subst-map '()) 188 | 189 | (define subst-map-length t:size) 190 | 191 | ; Returns #f if not found, or a pair of u and the result of the lookup. 192 | ; This distinguishes between #f indicating absence and being the result. 193 | (define subst-map-lookup 194 | (lambda (u S) 195 | (let ((res (t:lookup (var-idx u) S))) 196 | (if res 197 | (data-val res) 198 | unbound)))) 199 | 200 | (define (subst-map-add S var val) 201 | (t:bind (var-idx var) val S)) 202 | 203 | (define subst-map-eq? eq?) 204 | 205 | 206 | ; Alternative (unused) substitution representation, using alists. 207 | ; Performance with the tries is usually about the same and 208 | ; can be much better for huge substitutions. 209 | 210 | #| 211 | (define empty-subst-map '()) 212 | 213 | (define subst-map-length length) 214 | 215 | ; Returns #f if not found, or a pair of u and the result of the lookup. 216 | ; This distinguishes between #f indicating absence and being the result. 217 | (define subst-map-lookup 218 | (lambda (u S) 219 | (let ((res (assq u S))) 220 | (if res 221 | (cdr res) 222 | unbound)))) 223 | 224 | (define (subst-map-add S var val) 225 | (cons (cons var val) S)) 226 | 227 | (define subst-map-eq? eq?) 228 | |# 229 | 230 | 231 | ; Constraint store representation 232 | 233 | (define empty-C '()) 234 | 235 | (define set-c 236 | (lambda (v c st) 237 | (state (state-S st) 238 | (t:bind (var-idx v) c (state-C st)) 239 | (state-depth st) 240 | (state-deferred st)))) 241 | 242 | (define lookup-c 243 | (lambda (v st) 244 | (let ((res (t:lookup (var-idx v) (state-C st)))) 245 | (if res 246 | (data-val res) 247 | empty-c)))) 248 | 249 | ; t:unbind either is buggy or doesn't do what I would expect, so 250 | ; I implement remove by setting the value to the empty constraint record. 251 | (define remove-c 252 | (lambda (v st) 253 | (let ((res (t:bind (var-idx v) empty-c (state-C st)))) 254 | (state (state-S st) res (state-depth st) (state-deferred st))))) 255 | 256 | 257 | ; Misc. missing functions 258 | 259 | (define (remove-duplicates l) 260 | (cond ((null? l) 261 | '()) 262 | ((member (car l) (cdr l)) 263 | (remove-duplicates (cdr l))) 264 | (else 265 | (cons (car l) (remove-duplicates (cdr l)))))) 266 | 267 | (define (foldl f init seq) 268 | (if (null? seq) 269 | init 270 | (foldl f 271 | (f (car seq) init) 272 | (cdr seq)))) 273 | 274 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide run run* 4 | == =/= 5 | fresh 6 | conde 7 | symbolo numbero 8 | absento 9 | (all-defined-out)) 10 | 11 | ;; extra stuff for racket 12 | ;; due mostly to samth 13 | (define (list-sort f l) (sort l f)) 14 | 15 | (define (remp f l) (filter-not f l)) 16 | 17 | (define (call-with-string-output-port f) 18 | (define p (open-output-string)) 19 | (f p) 20 | (get-output-string p)) 21 | 22 | (define (exists f l) (ormap f l)) 23 | 24 | (define for-all andmap) 25 | 26 | (define (find f l) 27 | (cond [(memf f l) => car] [else #f])) 28 | 29 | (define memp memf) 30 | 31 | (define (var*? v) (var? (car v))) 32 | 33 | 34 | ; Substitution representation 35 | 36 | (define empty-subst-map (hasheq)) 37 | 38 | (define subst-map-length hash-count) 39 | 40 | ; Returns #f if not found, or a pair of u and the result of the lookup. 41 | ; This distinguishes between #f indicating absence and being the result. 42 | (define subst-map-lookup 43 | (lambda (u S) 44 | (hash-ref S u unbound))) 45 | 46 | (define (subst-map-add S var val) 47 | (hash-set S var val)) 48 | 49 | (define subst-map-eq? eq?) 50 | 51 | 52 | ; Constraint store representation 53 | 54 | (define empty-C (hasheq)) 55 | 56 | (define set-c 57 | (lambda (v c st) 58 | (state (state-S st) (hash-set (state-C st) v c)))) 59 | 60 | (define lookup-c 61 | (lambda (v st) 62 | (hash-ref (state-C st) v empty-c))) 63 | 64 | (define remove-c 65 | (lambda (v st) 66 | (state (state-S st) (hash-remove (state-C st) v)))) 67 | 68 | 69 | (include "mk.scm") 70 | -------------------------------------------------------------------------------- /code/advanced-hangouts/hangout-7/test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-2/intro-hangout-2.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (pmatch 5 4 | ((,one ,two) 5 | one) 6 | ((,one ,two ,three) 7 | (list three two one)) 8 | ((,first . ,rest) 9 | rest) 10 | (else 'no-match)) 11 | 12 | (define my-match 13 | (lambda (x) 14 | (pmatch x 15 | ((,one ,two) 16 | one) 17 | ((,one ,two ,three) 18 | (list three two one)) 19 | ((,first . ,rest) 20 | rest) 21 | (else 'no-match)))) 22 | 23 | (define valid-expression? 24 | (lambda (expr) 25 | (pmatch expr 26 | (,x (guard (symbol? x)) 27 | #t) 28 | (,b (guard (boolean? b)) 29 | #t) 30 | (,n (guard (number? n)) 31 | #t) 32 | ((lambda (,x) ,body) 33 | #t) 34 | ((,e1 ,e2) ;; procedure application 35 | #t) 36 | (else 37 | #f)))) 38 | 39 | 40 | ;; lambda calculus 41 | 42 | ;; x <- variable 43 | ;; (lambda (x) e) <- lambda or abstraction 44 | ;; (e e) <- application 45 | 46 | (define lambda-calculus-expression? 47 | (lambda (expr) 48 | (pmatch expr 49 | (,x ;; variable 50 | (guard (symbol? x)) 51 | #t) 52 | ((lambda (,x) ,body) ;; lambda/abstraction 53 | (guard (symbol? x)) 54 | (lambda-calculus-expression? body)) 55 | ((,e1 ,e2) ;; application 56 | (and 57 | (lambda-calculus-expression? e1) 58 | (lambda-calculus-expression? e2))) 59 | (else 60 | #f)))) 61 | 62 | 63 | 64 | ;; Church-encoding of arithmetic 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | #!eof 79 | 80 | ;; member 81 | ;; rember, rember*, deep-rember* 82 | ;; filter 83 | ;; map 84 | 85 | (member 'x '()) => #f 86 | (member 'x '(a x f x g)) => #t 87 | (member 'x '(x f x g)) => #t 88 | (member 'x '(a f g)) => #f 89 | (member 'x '(x f g)) => #t 90 | (member 'foo '(a foo g)) => #t 91 | 92 | (define member 93 | (lambda (x l) 94 | (cond 95 | ((null? l) #f) 96 | ((equal? (car l) x) #t) 97 | (else (member x (cdr l)))))) 98 | 99 | (rember 'x '()) => () 100 | (rember 'x '(x f x g)) => (f x g) 101 | (rember 'x '(f g)) => (f g) 102 | (rember 'x '(f x g)) => (f g) 103 | 104 | (define rember 105 | (lambda (x l) 106 | (cond 107 | ((null? l) '()) 108 | ((equal? (car l) x) (cdr l)) 109 | (else (cons (car l) (rember x (cdr l))))))) 110 | 111 | (rember* 'x '()) => () 112 | (rember* 'x '(x f x g)) => (f g) 113 | (rember* 'x '(f g)) => (f g) 114 | (rember* 'x '(f x g)) => (f g) 115 | (rember* 'x '((x x) g x (f (x a)) (x (((h x)) j)) x b)) => 116 | ((x x) g (f (x a)) (x (((h x)) j)) b) 117 | 118 | (define rember* 119 | (lambda (x l) 120 | (cond 121 | ((null? l) '()) 122 | ((equal? (car l) x) (rember* x (cdr l))) 123 | (else (cons (car l) (rember* x (cdr l))))))) 124 | 125 | (deep-rember* 'x '()) => () 126 | (deep-rember* 'x '((x x) g x (f (x a)) (x (((h x)) j)) x b)) 127 | => 128 | (() g (f (a)) ((((h)) j)) b) 129 | 130 | (define deep-rember* 131 | (lambda (x l) 132 | (cond 133 | ((null? l) '()) 134 | ;; new clause for deep recursion 135 | ((pair? (car l)) 136 | (cons (deep-rember* x (car l)) 137 | (deep-rember* x (cdr l)))) 138 | ((equal? (car l) x) (deep-rember* x (cdr l))) 139 | (else (cons (car l) (deep-rember* x (cdr l))))))) 140 | 141 | ;;; filter-in 142 | (filter odd? '()) => '() 143 | (filter odd? '(1 2 3 4 5 6)) => (1 3 5) 144 | (filter odd? '(2 3 4 5 6)) => (3 5) 145 | 146 | (define filter 147 | (lambda (f l) 148 | (cond 149 | ((null? l) '()) 150 | ((f (car l)) 151 | (cons (car l) (filter f (cdr l)))) 152 | (else (filter f (cdr l)))))) 153 | 154 | 155 | 156 | ;;; quotation 157 | 158 | (+ 3 4) 159 | 160 | '(+ 3 4) is equivalent to (quote (+ 3 4)) 161 | 162 | (quote datum) => datum 163 | 164 | ----------------------- 165 | 166 | ;; quasiquote, backquote, backtick 167 | 168 | `(a b c) is equivalent to (quasiquote (a b c)) 169 | 170 | ;; unquote, comma 171 | 172 | ,x is equivalent to (unquote x) 173 | 174 | (define x 5) 175 | 176 | (3 x 17) => (3 5 17) 177 | 178 | (list 3 x 17) 179 | (cons 3 (cons x (cons 17 '()))) 180 | 181 | (define x 6) 182 | 183 | `(3 ,x 17) = (quasiquote (3 (unquote x) 17)) 184 | (3 6 17) 185 | 186 | (let ((x 7)) 187 | x) 188 | = 189 | ((lambda (x) x) 7) 190 | 191 | (let ((x 7)) 192 | `(3 ,x 17)) 193 | 194 | 195 | 196 | (define make-my-list 197 | (lambda (x) 198 | `(3 ,x 17))) 199 | 200 | (define make-my-list-flatten 201 | (lambda (x) 202 | `(3 ,@x 17))) 203 | 204 | ;; unquote-splicing 205 | 206 | `(a ,(+ 3 4) c) 207 | 208 | -------------------------------- 209 | 210 | ;; macros and syntactic abstraction 211 | 212 | (let ((x (+ 3 4))) 213 | (* x x)) 214 | 215 | is equivalent to 216 | 217 | ((lambda (x) (* x x)) 218 | (+ 3 4)) 219 | 220 | => 221 | 49 222 | 223 | my-let 224 | 225 | 226 | ;; x e 227 | (my-let ((x (+ 3 4))) 228 | ;; body 229 | (* x x)) 230 | 231 | (my-let ((x (+ 3 4))) 232 | (* x x)) 233 | 234 | 235 | expand => 236 | 237 | ((lambda (x) (* x x)) 238 | (+ 3 4)) 239 | 240 | 241 | (define-syntax my-let 242 | (syntax-rules () 243 | ((my-let ((x e)) body) ;; pattern 244 | ;; template 245 | ((lambda (x) body) 246 | e)))) 247 | 248 | 249 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-2/pmatch.scm: -------------------------------------------------------------------------------- 1 | ;; This is a new version of pmatch (August 8, 2012). 2 | ;; It has two important new features: 3 | ;; 1. It allows for a name to be given to the pmatch if an error ensues. 4 | ;; 2. A line from the specification has been removed. (see below). Without 5 | ;; that line removed, it was impossible for a pattern to be (quote ,x), 6 | ;; which might be worth having especially when we write an interpreter 7 | ;; for Scheme, which includes quote as a language form. 8 | 9 | ;;; Code written by Oleg Kiselyov 10 | ;; (http://pobox.com/~oleg/ftp/) 11 | ;;; 12 | ;;; Taken from leanTAP.scm 13 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 14 | 15 | ; A simple linear pattern matcher 16 | ; It is efficient (generates code at macro-expansion time) and simple: 17 | ; it should work on any R5RS (and R6RS) Scheme system. 18 | 19 | ; (pmatch exp ...[]) 20 | ; ::= ( exp ...) 21 | ; ::= (else exp ...) 22 | ; ::= boolean exp | () 23 | ; :: = 24 | ; ,var -- matches always and binds the var 25 | ; pattern must be linear! No check is done 26 | ; _ -- matches always 27 | ; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) 28 | ; exp -- comparison with exp (using equal?) 29 | ; ( ...) -- matches the list of patterns 30 | ; ( . ) -- ditto 31 | ; () -- matches the empty list 32 | 33 | (define-syntax pmatch 34 | (syntax-rules (else guard) 35 | ((_ v (e ...) ...) 36 | (pmatch-aux #f v (e ...) ...)) 37 | ((_ v name (e ...) ...) 38 | (pmatch-aux name v (e ...) ...)))) 39 | 40 | (define-syntax pmatch-aux 41 | (syntax-rules (else guard) 42 | ((_ name (rator rand ...) cs ...) 43 | (let ((v (rator rand ...))) 44 | (pmatch-aux name v cs ...))) 45 | ((_ name v) 46 | (begin 47 | (if 'name 48 | (printf "pmatch ~s failed\n~s\n" 'name v) 49 | (printf "pmatch failed\n ~s\n" v)) 50 | (error 'pmatch "match failed"))) 51 | ((_ name v (else e0 e ...)) (begin e0 e ...)) 52 | ((_ name v (pat (guard g ...) e0 e ...) cs ...) 53 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 54 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 55 | ((_ name v (pat e0 e ...) cs ...) 56 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 57 | (ppat v pat (begin e0 e ...) (fk)))))) 58 | 59 | (define-syntax ppat 60 | (syntax-rules (? comma unquote) 61 | ((_ v ? kt kf) kt) 62 | ((_ v () kt kf) (if (null? v) kt kf)) 63 | ; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 64 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 65 | ((_ v (x . y) kt kf) 66 | (if (pair? v) 67 | (let ((vx (car v)) (vy (cdr v))) 68 | (ppat vx x (ppat vy y kt kf) kf)) 69 | kf)) 70 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 71 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-3/transcript-part2.scm: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.4.1 2 | Copyright 1984-2016 Cisco Systems, Inc. 3 | 4 | > (let ((x (+ 2 3))) 5 | (let ((x 7)) 6 | x)) 7 | 7 8 | > (let ((x (+ 2 3))) 9 | (let ((x 7)) 10 | x)) 11 | 7 12 | > 13 | ;; () 14 | (let ((x (+ 2 3))) 15 | ;; ((x . 5)) 16 | (let ((x 7)) 17 | ;; ((x . 7) (x . 5)) 18 | x)) 19 | 7 20 | > 21 | ;; () 22 | (let ((x (+ 2 3))) 23 | ;; ((x . 5)) 24 | (let ((y 7)) 25 | ;; ((y . 7) (x . 5)) 26 | y)) 27 | 7 28 | > 29 | ;; () 30 | (let ((x (+ 2 3))) 31 | ;; ((x . 5)) 32 | (let ((y864287467836487 7)) ;; alpha-renaming 33 | ;; ((y864287467836487 . 7) (x . 5)) 34 | y864287467836487)) 35 | 7 36 | > (gensym "y") 37 | #{y pfv8ch3j8hvgae47o3rqxdkce-0} 38 | > y 39 | 40 | Exception: variable y is not bound 41 | Type (debug) to enter the debugger. 42 | > (let ((x (+ 2 3))) 43 | (list 44 | (let ((x 7)) 45 | x) 46 | x)) 47 | (7 5) 48 | > (let ((x (+ 2 3))) 49 | (list 50 | (let ((x 7)) 51 | x) 52 | x)) -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-4/intro-hangout-4.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | [(test name expr expected-val) 6 | (let ((v expr)) 7 | (if (equal? v expected-val) 8 | (begin 9 | (display "passed test ") 10 | (write name) 11 | (newline)) 12 | (error 'name 13 | (format "\nTest ~s failed!!\nExpected ~s, but got ~s" 14 | name 15 | expected-val 16 | v))))])) 17 | 18 | (define empty-env 19 | '()) 20 | 21 | (define lookup 22 | (lambda (x env) 23 | (cond 24 | ((null? env) 25 | (error 'lookup (format "unbound variable ~s" x))) 26 | ((eq? (caar env) x) 27 | (cdar env)) 28 | (else (lookup x (cdr env)))))) 29 | 30 | ;; lambda calculus 31 | ;; 32 | ;; x variable 33 | ;; (lambda (x) expr) lambda expression (abstract) 34 | ;; (e e) application 35 | 36 | (define eval-expr 37 | (lambda (expr env) 38 | (pmatch expr 39 | [,n (guard (number? n)) 40 | n] 41 | [(zero? ,e) 42 | (zero? (eval-expr e env))] 43 | [(add1 ,e) 44 | (add1 (eval-expr e env))] 45 | [(sub1 ,e) 46 | (sub1 (eval-expr e env))] 47 | [(* ,e1 ,e2) 48 | (* (eval-expr e1 env) (eval-expr e2 env))] 49 | [(if ,e1 ,e2 ,e3) 50 | (if (eval-expr e1 env) 51 | (eval-expr e2 env) 52 | (eval-expr e3 env))] 53 | [,x (guard (symbol? x)) ; variable 54 | (lookup x env)] 55 | [(lambda (,x) ,body) (guard (symbol? x)) ; lambda/abstraction 56 | `(closure ,x ,body ,env)] 57 | [(,rator ,rand) ;application 58 | (apply-proc (eval-expr rator env) (eval-expr rand env))]))) 59 | 60 | ;; ;; rator rand 61 | ;; ((lambda (y) (* y y)) (add1 5)) 62 | ;; => 63 | ;; (closure y (* y y) ()) ; value of the rator (proc) 64 | ;; 6 ; value of the rand (val) 65 | 66 | ;; (* y y) ((y . 6)) 67 | 68 | ;; (((lambda (y) 69 | ;; (lambda (z) 70 | ;; (* y z))) 71 | ;; (add1 4)) 72 | ;; (sub1 7)) 73 | 74 | ;; ((lambda (y) 75 | ;; (lambda (z) 76 | ;; (* y z))) 77 | ;; (add1 4)) 78 | 79 | ;; ((lambda (y) ;; => (closure y (lambda (z) (* y z)) ()) 80 | ;; (lambda (z) 81 | ;; (* y z))) 82 | ;; (add1 4) ;; => 5 83 | ;; ) 84 | 85 | ;; (closure y (lambda (z) (* y z)) ()) proc 86 | ;; 5 val 87 | 88 | ;; (lambda (z) (* y z)) in ((y . 5)) 89 | 90 | ;; (closure z (* y z) ((y . 5))) proc 91 | ;; 6 val 92 | 93 | ;; (* y z) in ((z . 6) (y . 5)) 94 | 95 | (define apply-proc 96 | (lambda (proc val) 97 | (pmatch proc 98 | [(closure ,x ,body ,env) 99 | (eval-expr body `((,x . ,val) . ,env))]))) 100 | 101 | (test "! 5" 102 | (eval-expr '(((lambda (!) 103 | (lambda (n) 104 | ((! !) n))) 105 | (lambda (!) 106 | (lambda (n) 107 | (if (zero? n) 108 | 1 109 | (* n ((! !) (sub1 n))))))) 110 | 5) 111 | empty-env) 112 | 120) 113 | 114 | (test "eval-expr lambda" 115 | (eval-expr '(lambda (y) (* y y)) '((z . 17))) 116 | '(closure y (* y y) ((z . 17)))) 117 | 118 | (test "eval-expr app 1" 119 | (eval-expr '((lambda (y) (* y y)) (add1 5)) '((z . 17))) 120 | 36) 121 | 122 | (test "eval-expr app 2" 123 | (eval-expr '(((lambda (y) 124 | (lambda (z) 125 | (* y z))) 126 | (add1 4)) 127 | (sub1 7)) 128 | empty-env) 129 | 30) 130 | 131 | (test "eval-expr var" 132 | (eval-expr 'y '((y . 5))) 133 | 5) 134 | 135 | (test "eval-expr var/add1" 136 | (eval-expr '(add1 y) '((y . 5))) 137 | 6) 138 | 139 | (test "eval-expr num" 140 | (eval-expr '5 empty-env) 141 | 5) 142 | 143 | (test "eval-expr bignum" 144 | (eval-expr '5983724897985749873827589372589732985798237598273598 empty-env) 145 | 5983724897985749873827589372589732985798237598273598) 146 | 147 | (test "eval-expr zero? 1" 148 | (eval-expr '(zero? 0) empty-env) 149 | #t) 150 | 151 | (test "eval-expr zero? 2" 152 | (eval-expr '(zero? 1) empty-env) 153 | #f) 154 | 155 | (test "eval-expr zero? 3" 156 | (eval-expr '(zero? (add1 0)) empty-env) 157 | #f) 158 | 159 | (test "eval-expr zero? 4" 160 | (eval-expr '(zero? (sub1 1)) empty-env) 161 | #t) 162 | 163 | (test "eval-expr add1" 164 | (eval-expr '(add1 (add1 5)) empty-env) 165 | 7) 166 | 167 | (test "eval-expr sub1" 168 | (eval-expr '(sub1 (sub1 5)) empty-env) 169 | 3) 170 | 171 | (test "eval-expr * 1" 172 | (eval-expr '(* 3 4) empty-env) 173 | 12) 174 | 175 | (test "eval-expr * 2" 176 | (eval-expr '(* (* 3 4) 5) empty-env) 177 | 60) 178 | 179 | (test "eval-expr * 3" 180 | (eval-expr '(* 5 (* 3 4)) empty-env) 181 | 60) 182 | 183 | (test "eval-expr if 1" 184 | (eval-expr '(if (zero? 0) 5 6) empty-env) 185 | 5) 186 | 187 | (test "eval-expr if 2" 188 | (eval-expr '(if (zero? 1) 5 6) empty-env) 189 | 6) 190 | 191 | (test "eval-expr if 3" 192 | (eval-expr '(if (zero? (* 3 4)) (add1 6) (sub1 6)) empty-env) 193 | 5) 194 | 195 | 196 | #!eof 197 | 198 | (let ((x (+ 2 3))) 199 | ;; x -> 5 200 | (+ (let ((y (* x x))) 201 | ;; y -> 25 202 | (let ((x 7)) 203 | ;; x -> 7 204 | (+ x y))) 205 | x)) 206 | 207 | ;; environment 208 | 209 | ;; association-list (alist) represention of environments 210 | ;; () empty environment 211 | (let ((x (+ 2 3))) 212 | ;; ((x . 5)) 213 | (let ((y (* x x))) 214 | ;; ((y . 25) (x . 5)) 215 | (let ((x 7)) 216 | ;; ((x . 7) (y . 25) (x . 5)) 217 | (+ x y)))) 218 | 219 | 220 | ;; tagged-list representation of environments 221 | ;; (empty-env) 222 | 223 | ;; (ext-env x 5 (empty-env)) 224 | 225 | ;; (ext-env y 25 (ext-env x 5 (empty-env))) 226 | 227 | ;; (ext-env x 7 (ext-env y 25 (ext-env x 5 (empty-env)))) 228 | 229 | 230 | 231 | (define lookup 232 | (lambda (x env) 233 | (cond 234 | ((null? env) 235 | (error 'lookup (format "unbound variable ~s" x))) 236 | ((eq? (car (car env)) x) 237 | (cdr (car env))) 238 | (else (lookup x (cdr env)))))) 239 | 240 | (lookup 'y '((y . 25) (x . 5))) 241 | (lookup 'x '((y . 25) (x . 5))) 242 | (lookup 'z '((y . 25) (x . 5))) 243 | 244 | ;; (lookup 'y '()) 245 | 246 | (define lookup 247 | (lambda (x env) 248 | (cond 249 | ((null? env) 250 | (error 'lookup (format "unbound variable ~s" x))) 251 | ((eq? (caar env) x) 252 | (cdar env)) 253 | (else (lookup x (cdr env)))))) 254 | 255 | (lookup 'y '((y . 25) (x . 5))) 256 | (lookup 'x '((y . 25) (x . 5))) 257 | (lookup 'z '((y . 25) (x . 5))) 258 | 259 | 260 | (define lookup 261 | (lambda (x env) 262 | (pmatch env 263 | (() 264 | (error 'lookup (format "unbound variable ~s" x))) 265 | (((,y . ,v) . ,rest-env) 266 | (if (eq? y x) 267 | v 268 | (lookup x rest-env)))))) 269 | 270 | (lookup 'y '((y . 25) (x . 5))) 271 | (lookup 'x '((y . 25) (x . 5))) 272 | (lookup 'z '((y . 25) (x . 5))) 273 | 274 | 275 | ;; tagged-list representation of environments 276 | ;; (empty-env) 277 | 278 | ;; (ext-env x 5 (empty-env)) 279 | 280 | ;; (ext-env y 25 (ext-env x 5 (empty-env))) 281 | 282 | (define lookup 283 | (lambda (x env) 284 | (pmatch env 285 | ((empty-env) 286 | (error 'lookup (format "unbound variable ~s" x))) 287 | ((ext-env ,y ,v ,rest-env) 288 | (if (eq? y x) 289 | v 290 | (lookup x rest-env)))))) 291 | 292 | (lookup 'y '(ext-env x 7 (ext-env y 25 (ext-env x 5 (empty-env))))) 293 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-4/pmatch.scm: -------------------------------------------------------------------------------- 1 | ;; This is a new version of pmatch (August 8, 2012). 2 | ;; It has two important new features: 3 | ;; 1. It allows for a name to be given to the pmatch if an error ensues. 4 | ;; 2. A line from the specification has been removed. (see below). Without 5 | ;; that line removed, it was impossible for a pattern to be (quote ,x), 6 | ;; which might be worth having especially when we write an interpreter 7 | ;; for Scheme, which includes quote as a language form. 8 | 9 | ;;; Code written by Oleg Kiselyov 10 | ;; (http://pobox.com/~oleg/ftp/) 11 | ;;; 12 | ;;; Taken from leanTAP.scm 13 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 14 | 15 | ; A simple linear pattern matcher 16 | ; It is efficient (generates code at macro-expansion time) and simple: 17 | ; it should work on any R5RS (and R6RS) Scheme system. 18 | 19 | ; (pmatch exp ...[]) 20 | ; ::= ( exp ...) 21 | ; ::= (else exp ...) 22 | ; ::= boolean exp | () 23 | ; :: = 24 | ; ,var -- matches always and binds the var 25 | ; pattern must be linear! No check is done 26 | ; _ -- matches always 27 | ; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) 28 | ; exp -- comparison with exp (using equal?) 29 | ; ( ...) -- matches the list of patterns 30 | ; ( . ) -- ditto 31 | ; () -- matches the empty list 32 | 33 | (define-syntax pmatch 34 | (syntax-rules (else guard) 35 | ((_ v (e ...) ...) 36 | (pmatch-aux #f v (e ...) ...)) 37 | ((_ v name (e ...) ...) 38 | (pmatch-aux name v (e ...) ...)))) 39 | 40 | (define-syntax pmatch-aux 41 | (syntax-rules (else guard) 42 | ((_ name (rator rand ...) cs ...) 43 | (let ((v (rator rand ...))) 44 | (pmatch-aux name v cs ...))) 45 | ((_ name v) 46 | (begin 47 | (if 'name 48 | (printf "pmatch ~s failed\n~s\n" 'name v) 49 | (printf "pmatch failed\n ~s\n" v)) 50 | (error 'pmatch "match failed"))) 51 | ((_ name v (else e0 e ...)) (begin e0 e ...)) 52 | ((_ name v (pat (guard g ...) e0 e ...) cs ...) 53 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 54 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 55 | ((_ name v (pat e0 e ...) cs ...) 56 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 57 | (ppat v pat (begin e0 e ...) (fk)))))) 58 | 59 | (define-syntax ppat 60 | (syntax-rules (? comma unquote) 61 | ((_ v ? kt kf) kt) 62 | ((_ v () kt kf) (if (null? v) kt kf)) 63 | ; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 64 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 65 | ((_ v (x . y) kt kf) 66 | (if (pair? v) 67 | (let ((vx (car v)) (vy (cdr v))) 68 | (ppat vx x (ppat vy y kt kf) kf)) 69 | kf)) 70 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 71 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-5/first-order-interp.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | [(test name expr expected-val) 6 | (let ((v expr)) 7 | (if (equal? v expected-val) 8 | (begin 9 | (display "passed test ") 10 | (write name) 11 | (newline)) 12 | (error 'name 13 | (format "\nTest ~s failed!!\nExpected ~s, but got ~s" 14 | name 15 | expected-val 16 | v))))])) 17 | 18 | 19 | (define empty-env 20 | '()) 21 | 22 | (define lookup 23 | (lambda (x env) 24 | (cond 25 | ((null? env) 26 | (error 'lookup (format "unbound variable ~s" x))) 27 | ((eq? (caar env) x) 28 | (cdar env)) 29 | (else (lookup x (cdr env)))))) 30 | 31 | (define eval-expr 32 | (lambda (expr env) 33 | (pmatch expr 34 | [,n (guard (number? n)) 35 | n] 36 | [(zero? ,e) 37 | (zero? (eval-expr e env))] 38 | [(add1 ,e) 39 | (add1 (eval-expr e env))] 40 | [(sub1 ,e) 41 | (sub1 (eval-expr e env))] 42 | [(* ,e1 ,e2) 43 | (* (eval-expr e1 env) (eval-expr e2 env))] 44 | [(if ,e1 ,e2 ,e3) 45 | (if (eval-expr e1 env) 46 | (eval-expr e2 env) 47 | (eval-expr e3 env))] 48 | [,x (guard (symbol? x)) ; variable 49 | (lookup x env)] 50 | [(lambda (,x) ,body) (guard (symbol? x)) ; lambda/abstraction 51 | `(closure ,x ,body ,env)] 52 | [(,rator ,rand) ;application 53 | (apply-proc (eval-expr rator env) (eval-expr rand env))]))) 54 | 55 | (define apply-proc 56 | (lambda (proc val) 57 | (pmatch proc 58 | [(closure ,x ,body ,env) 59 | (eval-expr body `((,x . ,val) . ,env))]))) 60 | 61 | (test "! 5" 62 | (eval-expr '(((lambda (!) 63 | (lambda (n) 64 | ((! !) n))) 65 | (lambda (!) 66 | (lambda (n) 67 | (if (zero? n) 68 | 1 69 | (* n ((! !) (sub1 n))))))) 70 | 5) 71 | empty-env) 72 | 120) 73 | 74 | (test "eval-expr lambda" 75 | (eval-expr '(lambda (y) (* y y)) '((z . 17))) 76 | '(closure y (* y y) ((z . 17)))) 77 | 78 | (test "eval-expr app 1" 79 | (eval-expr '((lambda (y) (* y y)) (add1 5)) '((z . 17))) 80 | 36) 81 | 82 | (test "eval-expr app 2" 83 | (eval-expr '(((lambda (y) 84 | (lambda (z) 85 | (* y z))) 86 | (add1 4)) 87 | (sub1 7)) 88 | empty-env) 89 | 30) 90 | 91 | (test "eval-expr var" 92 | (eval-expr 'y '((y . 5))) 93 | 5) 94 | 95 | (test "eval-expr var/add1" 96 | (eval-expr '(add1 y) '((y . 5))) 97 | 6) 98 | 99 | (test "eval-expr num" 100 | (eval-expr '5 empty-env) 101 | 5) 102 | 103 | (test "eval-expr bignum" 104 | (eval-expr '5983724897985749873827589372589732985798237598273598 empty-env) 105 | 5983724897985749873827589372589732985798237598273598) 106 | 107 | (test "eval-expr zero? 1" 108 | (eval-expr '(zero? 0) empty-env) 109 | #t) 110 | 111 | (test "eval-expr zero? 2" 112 | (eval-expr '(zero? 1) empty-env) 113 | #f) 114 | 115 | (test "eval-expr zero? 3" 116 | (eval-expr '(zero? (add1 0)) empty-env) 117 | #f) 118 | 119 | (test "eval-expr zero? 4" 120 | (eval-expr '(zero? (sub1 1)) empty-env) 121 | #t) 122 | 123 | (test "eval-expr add1" 124 | (eval-expr '(add1 (add1 5)) empty-env) 125 | 7) 126 | 127 | (test "eval-expr sub1" 128 | (eval-expr '(sub1 (sub1 5)) empty-env) 129 | 3) 130 | 131 | (test "eval-expr * 1" 132 | (eval-expr '(* 3 4) empty-env) 133 | 12) 134 | 135 | (test "eval-expr * 2" 136 | (eval-expr '(* (* 3 4) 5) empty-env) 137 | 60) 138 | 139 | (test "eval-expr * 3" 140 | (eval-expr '(* 5 (* 3 4)) empty-env) 141 | 60) 142 | 143 | (test "eval-expr if 1" 144 | (eval-expr '(if (zero? 0) 5 6) empty-env) 145 | 5) 146 | 147 | (test "eval-expr if 2" 148 | (eval-expr '(if (zero? 1) 5 6) empty-env) 149 | 6) 150 | 151 | (test "eval-expr if 3" 152 | (eval-expr '(if (zero? (* 3 4)) (add1 6) (sub1 6)) empty-env) 153 | 5) 154 | 155 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-5/interp-dynamic-scope.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | [(test name expr expected-val) 6 | (let ((v expr)) 7 | (if (equal? v expected-val) 8 | (begin 9 | (display "passed test ") 10 | (write name) 11 | (newline)) 12 | (error 'name 13 | (format "\nTest ~s failed!!\nExpected ~s, but got ~s" 14 | name 15 | expected-val 16 | v))))])) 17 | 18 | (define eval-expr-lexical 19 | (lambda (expr env) 20 | (pmatch expr 21 | [,n (guard (number? n)) 22 | n] 23 | [(zero? ,e) 24 | (zero? (eval-expr-lexical e env))] 25 | [(add1 ,e) 26 | (add1 (eval-expr-lexical e env))] 27 | [(sub1 ,e) 28 | (sub1 (eval-expr-lexical e env))] 29 | [(* ,e1 ,e2) 30 | (* (eval-expr-lexical e1 env) (eval-expr-lexical e2 env))] 31 | [(+ ,e1 ,e2) 32 | (+ (eval-expr-lexical e1 env) (eval-expr-lexical e2 env))] 33 | [(if ,e1 ,e2 ,e3) 34 | (if (eval-expr-lexical e1 env) 35 | (eval-expr-lexical e2 env) 36 | (eval-expr-lexical e3 env))] 37 | #| 38 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 39 | (eval-expr-lexical `((lambda (,x) ,body) ,e) env)] 40 | |# 41 | 42 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 43 | (let ((arg (eval-expr-lexical e env))) 44 | (eval-expr-lexical body (lambda (y) 45 | (if (eq? x y) 46 | arg 47 | (env y)))))] 48 | 49 | [,x (guard (symbol? x)) 50 | (env x)] 51 | [(lambda (,x) ,body) (guard (symbol? x)) 52 | (lambda (arg env^) 53 | (eval-expr-lexical body (lambda (y) 54 | (if (eq? x y) 55 | arg 56 | (env y)))))] 57 | [(,rator ,rand) 58 | ((eval-expr-lexical rator env) (eval-expr-lexical rand env) env)]))) 59 | 60 | 61 | (define my-eval-lexical 62 | (lambda (expr) 63 | (eval-expr-lexical expr 64 | (lambda (y) (error 'lookup (format "unbound variable ~s" y)))))) 65 | 66 | (my-eval-lexical '(lambda (z) z)) 67 | 68 | (test "lexical let 1" 69 | (my-eval-lexical '(let ((z (* 3 4))) (sub1 z))) 70 | 11) 71 | 72 | (test "lexical let 2" 73 | (my-eval-lexical '(let ((x (sub1 6))) 74 | (let ((f (lambda (y) (+ y x)))) 75 | (let ((x (* 3 4))) 76 | (f x))))) 77 | 17) 78 | 79 | (test "lexical let 3" 80 | (my-eval-lexical '(let ((x (sub1 6))) 81 | (let ((f (lambda (y) (+ y x)))) 82 | (let ((y (* 3 4))) 83 | (f y))))) 84 | 17) 85 | 86 | (test "lexical ! 5" 87 | (my-eval-lexical '(((lambda (!) 88 | (lambda (n) 89 | ((! !) n))) 90 | (lambda (!) 91 | (lambda (n) 92 | (if (zero? n) 93 | 1 94 | (* n ((! !) (sub1 n))))))) 95 | 5)) 96 | 120) 97 | 98 | 99 | ;;;;; 100 | 101 | 102 | (define eval-expr-dynamic 103 | (lambda (expr env) 104 | (pmatch expr 105 | [,n (guard (number? n)) 106 | n] 107 | [(zero? ,e) 108 | (zero? (eval-expr-dynamic e env))] 109 | [(add1 ,e) 110 | (add1 (eval-expr-dynamic e env))] 111 | [(sub1 ,e) 112 | (sub1 (eval-expr-dynamic e env))] 113 | [(* ,e1 ,e2) 114 | (* (eval-expr-dynamic e1 env) (eval-expr-dynamic e2 env))] 115 | [(+ ,e1 ,e2) 116 | (+ (eval-expr-dynamic e1 env) (eval-expr-dynamic e2 env))] 117 | [(if ,e1 ,e2 ,e3) 118 | (if (eval-expr-dynamic e1 env) 119 | (eval-expr-dynamic e2 env) 120 | (eval-expr-dynamic e3 env))] 121 | #| 122 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 123 | (eval-expr-dynamic `((lambda (,x) ,body) ,e) env)] 124 | |# 125 | 126 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 127 | (let ((arg (eval-expr-dynamic e env))) 128 | (eval-expr-dynamic body (lambda (y) 129 | (if (eq? x y) 130 | arg 131 | (env y)))))] 132 | 133 | [,x (guard (symbol? x)) 134 | (env x)] 135 | [(lambda (,x) ,body) (guard (symbol? x)) 136 | (lambda (arg env^) 137 | (eval-expr-dynamic body (lambda (y) 138 | (if (eq? x y) 139 | arg 140 | (env^ y)))))] 141 | [(,rator ,rand) 142 | ((eval-expr-dynamic rator env) (eval-expr-dynamic rand env) env)]))) 143 | 144 | 145 | (define my-eval-dynamic 146 | (lambda (expr) 147 | (eval-expr-dynamic expr 148 | (lambda (y) (error 'lookup (format "unbound variable ~s" y)))1))) 149 | 150 | (my-eval-dynamic '(lambda (z) z)) 151 | 152 | (test "dynamic let 1" 153 | (my-eval-dynamic '(let ((z (* 3 4))) (sub1 z))) 154 | 11) 155 | 156 | (test "dynamic let 2" 157 | (my-eval-dynamic '(let ((x (sub1 6))) 158 | (let ((f (lambda (y) (+ y x)))) 159 | (let ((x (* 3 4))) 160 | (f x))))) 161 | 24) 162 | 163 | (test "dynamic let 3" 164 | (my-eval-dynamic '(let ((x (sub1 6))) 165 | (let ((f (lambda (y) (+ y x)))) 166 | (let ((y (* 3 4))) 167 | (f y))))) 168 | 17) 169 | 170 | (test "dynamic ! 5" 171 | (my-eval-dynamic '(((lambda (!) 172 | (lambda (n) 173 | ((! !) n))) 174 | (lambda (!) 175 | (lambda (n) 176 | (if (zero? n) 177 | 1 178 | (* n ((! !) (sub1 n))))))) 179 | 5)) 180 | 120) 181 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-5/interp-rep-ind.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | [(test name expr expected-val) 6 | (let ((v expr)) 7 | (if (equal? v expected-val) 8 | (begin 9 | (display "passed test ") 10 | (write name) 11 | (newline)) 12 | (error 'name 13 | (format "\nTest ~s failed!!\nExpected ~s, but got ~s" 14 | name 15 | expected-val 16 | v))))])) 17 | 18 | ;; representation dependent with respect to environments and procedures 19 | 20 | (define eval-expr 21 | (lambda (expr env) 22 | (pmatch expr 23 | [,n (guard (number? n)) 24 | n] 25 | [(zero? ,e) 26 | (zero? (eval-expr e env))] 27 | [(add1 ,e) 28 | (add1 (eval-expr e env))] 29 | [(sub1 ,e) 30 | (sub1 (eval-expr e env))] 31 | [(* ,e1 ,e2) 32 | (* (eval-expr e1 env) (eval-expr e2 env))] 33 | [(+ ,e1 ,e2) 34 | (+ (eval-expr e1 env) (eval-expr e2 env))] 35 | [(if ,e1 ,e2 ,e3) 36 | (if (eval-expr e1 env) 37 | (eval-expr e2 env) 38 | (eval-expr e3 env))] 39 | #| 40 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 41 | (eval-expr `((lambda (,x) ,body) ,e) env)] 42 | |# 43 | 44 | [(let ((,x ,e)) ,body) (guard (symbol? x)) 45 | (let ((arg (eval-expr e env))) 46 | (eval-expr body (ext-env x arg env)))] 47 | 48 | [,x (guard (symbol? x)) 49 | (apply-env x env)] 50 | [(lambda (,x) ,body) (guard (symbol? x)) 51 | (lambda (arg) 52 | (eval-expr body (ext-env x arg env)))] 53 | [(,rator ,rand) 54 | ((eval-expr rator env) (eval-expr rand env))]))) 55 | 56 | 57 | (define my-eval 58 | (lambda (expr) 59 | (eval-expr expr (make-empty-env)))) 60 | 61 | ;;; environment helpers -- higher order (procedural/functional representation) 62 | #| 63 | (define make-empty-env 64 | (lambda () 65 | (lambda (y) (error 'lookup (format "unbound variable ~s" y))))) 66 | 67 | (define apply-env 68 | (lambda (x env) 69 | (env x))) 70 | 71 | (define ext-env 72 | (lambda (x arg env) 73 | (lambda (y) 74 | (if (eq? x y) 75 | arg 76 | (apply-env y env))))) 77 | |# 78 | 79 | 80 | ;;; environment helpers -- first order (data structural/a-list representation) 81 | #| 82 | (define make-empty-env 83 | (lambda () 84 | '())) 85 | 86 | (define apply-env 87 | (lambda (x env) 88 | (cond 89 | ((null? env) 90 | (error 'lookup (format "unbound variable ~s" x))) 91 | ((eq? (caar env) x) 92 | (cdar env)) 93 | (else (apply-env x (cdr env)))))) 94 | 95 | (define ext-env 96 | (lambda (x arg env) 97 | `((,x . ,arg) . ,env))) 98 | |# 99 | 100 | ;;; environment helpers -- first order (data structural/tagged list representation) 101 | ;; exampples: 102 | ;; (empty-env) 103 | ;; (ext-env w (a b c) (ext-env z 5 (empty-env))) 104 | 105 | (define make-empty-env 106 | (lambda () 107 | '(empty-env))) 108 | 109 | (define apply-env 110 | (lambda (y env^) 111 | (pmatch env^ 112 | [(empty-env) 113 | (error 'lookup (format "unbound variable ~s" y))] 114 | [(ext-env ,x ,arg ,env) 115 | (if (eq? x y) 116 | arg 117 | (apply-env y env))]))) 118 | 119 | (define ext-env 120 | (lambda (x arg env) 121 | `(ext-env ,x ,arg ,env))) 122 | 123 | 124 | (my-eval '(lambda (z) z)) 125 | 126 | (test "let 1" 127 | (my-eval '(let ((z (* 3 4))) (sub1 z))) 128 | 11) 129 | 130 | (test "let 2" 131 | (my-eval '(let ((x (sub1 6))) 132 | (let ((f (lambda (y) (+ y x)))) 133 | (let ((x (* 3 4))) 134 | (f x))))) 135 | 17) 136 | 137 | (test "let 3" 138 | (my-eval '(let ((x (sub1 6))) 139 | (let ((f (lambda (y) (+ y x)))) 140 | (let ((y (* 3 4))) 141 | (f y))))) 142 | 17) 143 | 144 | (test "! 5" 145 | (my-eval '(((lambda (!) 146 | (lambda (n) 147 | ((! !) n))) 148 | (lambda (!) 149 | (lambda (n) 150 | (if (zero? n) 151 | 1 152 | (* n ((! !) (sub1 n))))))) 153 | 5)) 154 | 120) 155 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-5/pmatch.scm: -------------------------------------------------------------------------------- 1 | ;; This is a new version of pmatch (August 8, 2012). 2 | ;; It has two important new features: 3 | ;; 1. It allows for a name to be given to the pmatch if an error ensues. 4 | ;; 2. A line from the specification has been removed. (see below). Without 5 | ;; that line removed, it was impossible for a pattern to be (quote ,x), 6 | ;; which might be worth having especially when we write an interpreter 7 | ;; for Scheme, which includes quote as a language form. 8 | 9 | ;;; Code written by Oleg Kiselyov 10 | ;; (http://pobox.com/~oleg/ftp/) 11 | ;;; 12 | ;;; Taken from leanTAP.scm 13 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 14 | 15 | ; A simple linear pattern matcher 16 | ; It is efficient (generates code at macro-expansion time) and simple: 17 | ; it should work on any R5RS (and R6RS) Scheme system. 18 | 19 | ; (pmatch exp ...[]) 20 | ; ::= ( exp ...) 21 | ; ::= (else exp ...) 22 | ; ::= boolean exp | () 23 | ; :: = 24 | ; ,var -- matches always and binds the var 25 | ; pattern must be linear! No check is done 26 | ; _ -- matches always 27 | ; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) 28 | ; exp -- comparison with exp (using equal?) 29 | ; ( ...) -- matches the list of patterns 30 | ; ( . ) -- ditto 31 | ; () -- matches the empty list 32 | 33 | (define-syntax pmatch 34 | (syntax-rules (else guard) 35 | ((_ v (e ...) ...) 36 | (pmatch-aux #f v (e ...) ...)) 37 | ((_ v name (e ...) ...) 38 | (pmatch-aux name v (e ...) ...)))) 39 | 40 | (define-syntax pmatch-aux 41 | (syntax-rules (else guard) 42 | ((_ name (rator rand ...) cs ...) 43 | (let ((v (rator rand ...))) 44 | (pmatch-aux name v cs ...))) 45 | ((_ name v) 46 | (begin 47 | (if 'name 48 | (printf "pmatch ~s failed\n~s\n" 'name v) 49 | (printf "pmatch failed\n ~s\n" v)) 50 | (error 'pmatch "match failed"))) 51 | ((_ name v (else e0 e ...)) (begin e0 e ...)) 52 | ((_ name v (pat (guard g ...) e0 e ...) cs ...) 53 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 54 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 55 | ((_ name v (pat e0 e ...) cs ...) 56 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 57 | (ppat v pat (begin e0 e ...) (fk)))))) 58 | 59 | (define-syntax ppat 60 | (syntax-rules (? comma unquote) 61 | ((_ v ? kt kf) kt) 62 | ((_ v () kt kf) (if (null? v) kt kf)) 63 | ; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 64 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 65 | ((_ v (x . y) kt kf) 66 | (if (pair? v) 67 | (let ((vx (car v)) (vy (cdr v))) 68 | (ppat vx x (ppat vy y kt kf) kf)) 69 | kf)) 70 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 71 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-6/first-order-interp.scm: -------------------------------------------------------------------------------- 1 | (load "pmatch.scm") 2 | 3 | (define-syntax test 4 | (syntax-rules () 5 | [(test name expr expected-val) 6 | (let ((v expr)) 7 | (if (equal? v expected-val) 8 | (begin 9 | (display "passed test ") 10 | (write name) 11 | (newline)) 12 | (error 'name 13 | (format "\nTest ~s failed!!\nExpected ~s, but got ~s" 14 | name 15 | expected-val 16 | v))))])) 17 | 18 | 19 | (define empty-env 20 | '(empty-env)) 21 | 22 | (define lookup 23 | (lambda (y env^) 24 | (pmatch env^ 25 | ((empty-env) 26 | (error 'lookup (format "unbound variable ~s" y))) 27 | ((ext-env ,x ,val ,env) 28 | (if (eq? x y) 29 | val 30 | (lookup y env))) 31 | ((letrec-env ,bindings ,env) 32 | (let ((hc (assq y bindings))) 33 | (pmatch hc 34 | [(,h . (half-closure ,h-x ,h-body)) 35 | `(closure ,h-x ,h-body ,env^)] 36 | [#f (lookup y env)])))))) 37 | 38 | (define eval-expr 39 | (lambda (expr env) 40 | (pmatch expr 41 | [,b (guard (boolean? b)) 42 | b] 43 | [,n (guard (number? n)) 44 | n] 45 | [(zero? ,e) 46 | (zero? (eval-expr e env))] 47 | [(negative? ,e) 48 | (negative? (eval-expr e env))] 49 | [(add1 ,e) 50 | (add1 (eval-expr e env))] 51 | [(sub1 ,e) 52 | (sub1 (eval-expr e env))] 53 | [(- ,e) 54 | (- (eval-expr e env))] 55 | [(* ,e1 ,e2) 56 | (* (eval-expr e1 env) (eval-expr e2 env))] 57 | [(if ,e1 ,e2 ,e3) 58 | (if (eval-expr e1 env) 59 | (eval-expr e2 env) 60 | (eval-expr e3 env))] 61 | [,x (guard (symbol? x)) ; variable 62 | (lookup x env)] 63 | [(lambda (,x) ,body) (guard (symbol? x)) ; lambda/abstraction 64 | `(closure ,x ,body ,env)] 65 | [(letrec ,bindings ,letrec-body) 66 | (guard (legal-letrec-bindings? bindings)) 67 | (let ((processed-bindings 68 | (map 69 | (lambda (binding) 70 | (pmatch binding 71 | [(,f (lambda (,f-x) ,f-body)) 72 | `(,f . (half-closure ,f-x ,f-body))])) 73 | bindings))) 74 | (eval-expr letrec-body 75 | `(letrec-env ,processed-bindings ,env)))] 76 | [(,rator ,rand) ;application 77 | (apply-proc (eval-expr rator env) (eval-expr rand env))] 78 | [,else (error 'eval-expr 79 | (format "unknown expression type: ~s\n" 80 | expr))]))) 81 | 82 | (define legal-letrec-bindings? 83 | (lambda (bindings) 84 | (and (list? bindings) 85 | (andmap 86 | (lambda (binding) 87 | (pmatch binding 88 | [(,f (lambda (,f-x) ,f-body)) 89 | #t] 90 | [,else #f])) 91 | bindings)))) 92 | 93 | (define apply-proc 94 | (lambda (proc val) 95 | (pmatch proc 96 | [(closure ,x ,body ,env) 97 | (eval-expr body `(ext-env ,x ,val ,env))]))) 98 | 99 | (test "! 5" 100 | (eval-expr '(((lambda (!) 101 | (lambda (n) 102 | ((! !) n))) 103 | (lambda (!) 104 | (lambda (n) 105 | (if (zero? n) 106 | 1 107 | (* n ((! !) (sub1 n))))))) 108 | 5) 109 | empty-env) 110 | 120) 111 | 112 | (test "eval-expr lambda" 113 | (eval-expr '(lambda (y) (* y y)) `(ext-env z 17 ,empty-env)) 114 | '(closure y (* y y) (ext-env z 17 (empty-env)))) 115 | 116 | (test "eval-expr app 1" 117 | (eval-expr '((lambda (y) (* y y)) (add1 5)) `(ext-env z 17 ,empty-env)) 118 | 36) 119 | 120 | (test "eval-expr app 2" 121 | (eval-expr '(((lambda (y) 122 | (lambda (z) 123 | (* y z))) 124 | (add1 4)) 125 | (sub1 7)) 126 | empty-env) 127 | 30) 128 | 129 | (test "eval-expr var" 130 | (eval-expr 'y `(ext-env y 5 ,empty-env)) 131 | 5) 132 | 133 | (test "eval-expr var/add1" 134 | (eval-expr '(add1 y) `(ext-env y 5 ,empty-env)) 135 | 6) 136 | 137 | (test "eval-expr num" 138 | (eval-expr '5 empty-env) 139 | 5) 140 | 141 | (test "eval-expr bignum" 142 | (eval-expr '5983724897985749873827589372589732985798237598273598 empty-env) 143 | 5983724897985749873827589372589732985798237598273598) 144 | 145 | (test "eval-expr zero? 1" 146 | (eval-expr '(zero? 0) empty-env) 147 | #t) 148 | 149 | (test "eval-expr zero? 2" 150 | (eval-expr '(zero? 1) empty-env) 151 | #f) 152 | 153 | (test "eval-expr zero? 3" 154 | (eval-expr '(zero? (add1 0)) empty-env) 155 | #f) 156 | 157 | (test "eval-expr zero? 4" 158 | (eval-expr '(zero? (sub1 1)) empty-env) 159 | #t) 160 | 161 | (test "eval-expr add1" 162 | (eval-expr '(add1 (add1 5)) empty-env) 163 | 7) 164 | 165 | (test "eval-expr sub1" 166 | (eval-expr '(sub1 (sub1 5)) empty-env) 167 | 3) 168 | 169 | (test "eval-expr * 1" 170 | (eval-expr '(* 3 4) empty-env) 171 | 12) 172 | 173 | (test "eval-expr * 2" 174 | (eval-expr '(* (* 3 4) 5) empty-env) 175 | 60) 176 | 177 | (test "eval-expr * 3" 178 | (eval-expr '(* 5 (* 3 4)) empty-env) 179 | 60) 180 | 181 | (test "eval-expr if 1" 182 | (eval-expr '(if (zero? 0) 5 6) empty-env) 183 | 5) 184 | 185 | (test "eval-expr if 2" 186 | (eval-expr '(if (zero? 1) 5 6) empty-env) 187 | 6) 188 | 189 | (test "eval-expr if 3" 190 | (eval-expr '(if (zero? (* 3 4)) (add1 6) (sub1 6)) empty-env) 191 | 5) 192 | 193 | (test "eval-expr letrec even? 6" 194 | (eval-expr '(letrec ((even? (lambda (n) 195 | (if (zero? n) 196 | #t 197 | (odd? (sub1 n))))) 198 | (odd? (lambda (n) 199 | (if (zero? n) 200 | #f 201 | (even? (sub1 n)))))) 202 | (even? 6)) 203 | empty-env) 204 | #t) 205 | 206 | (test "eval-expr letrec even? 5" 207 | (eval-expr '(letrec ((even? (lambda (n) 208 | (if (zero? n) 209 | #t 210 | (odd? (sub1 n))))) 211 | (odd? (lambda (n) 212 | (if (zero? n) 213 | #f 214 | (even? (sub1 n)))))) 215 | (even? 5)) 216 | empty-env) 217 | #f) 218 | 219 | (test "eval-expr letrec even? negative 5" 220 | (eval-expr '(letrec ((even? (lambda (n) 221 | (if (negative? n) 222 | ((negative n) even?) 223 | (if (zero? n) 224 | #t 225 | (odd? (sub1 n)))))) 226 | (odd? (lambda (n) 227 | (if (negative? n) 228 | ((negative n) odd?) 229 | (if (zero? n) 230 | #f 231 | (even? (sub1 n)))))) 232 | (negative (lambda (n) 233 | (lambda (f) 234 | (f (- n)))))) 235 | (even? -5)) 236 | empty-env) 237 | #f) 238 | 239 | (test "eval-expr letrec even? negative 6" 240 | (eval-expr '(letrec ((even? (lambda (n) 241 | (if (negative? n) 242 | ((negative n) even?) 243 | (if (zero? n) 244 | #t 245 | (odd? (sub1 n)))))) 246 | (odd? (lambda (n) 247 | (if (negative? n) 248 | ((negative n) odd?) 249 | (if (zero? n) 250 | #f 251 | (even? (sub1 n)))))) 252 | (negative (lambda (n) 253 | (lambda (f) 254 | (f (- n)))))) 255 | (even? -6)) 256 | empty-env) 257 | #t) 258 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-6/pmatch.scm: -------------------------------------------------------------------------------- 1 | ;; This is a new version of pmatch (August 8, 2012). 2 | ;; It has two important new features: 3 | ;; 1. It allows for a name to be given to the pmatch if an error ensues. 4 | ;; 2. A line from the specification has been removed. (see below). Without 5 | ;; that line removed, it was impossible for a pattern to be (quote ,x), 6 | ;; which might be worth having especially when we write an interpreter 7 | ;; for Scheme, which includes quote as a language form. 8 | 9 | ;;; Code written by Oleg Kiselyov 10 | ;; (http://pobox.com/~oleg/ftp/) 11 | ;;; 12 | ;;; Taken from leanTAP.scm 13 | ;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log 14 | 15 | ; A simple linear pattern matcher 16 | ; It is efficient (generates code at macro-expansion time) and simple: 17 | ; it should work on any R5RS (and R6RS) Scheme system. 18 | 19 | ; (pmatch exp ...[]) 20 | ; ::= ( exp ...) 21 | ; ::= (else exp ...) 22 | ; ::= boolean exp | () 23 | ; :: = 24 | ; ,var -- matches always and binds the var 25 | ; pattern must be linear! No check is done 26 | ; _ -- matches always 27 | ; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) 28 | ; exp -- comparison with exp (using equal?) 29 | ; ( ...) -- matches the list of patterns 30 | ; ( . ) -- ditto 31 | ; () -- matches the empty list 32 | 33 | (define-syntax pmatch 34 | (syntax-rules (else guard) 35 | ((_ v (e ...) ...) 36 | (pmatch-aux #f v (e ...) ...)) 37 | ((_ v name (e ...) ...) 38 | (pmatch-aux name v (e ...) ...)))) 39 | 40 | (define-syntax pmatch-aux 41 | (syntax-rules (else guard) 42 | ((_ name (rator rand ...) cs ...) 43 | (let ((v (rator rand ...))) 44 | (pmatch-aux name v cs ...))) 45 | ((_ name v) 46 | (begin 47 | (if 'name 48 | (printf "pmatch ~s failed\n~s\n" 'name v) 49 | (printf "pmatch failed\n ~s\n" v)) 50 | (error 'pmatch "match failed"))) 51 | ((_ name v (else e0 e ...)) (begin e0 e ...)) 52 | ((_ name v (pat (guard g ...) e0 e ...) cs ...) 53 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 54 | (ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) 55 | ((_ name v (pat e0 e ...) cs ...) 56 | (let ((fk (lambda () (pmatch-aux name v cs ...)))) 57 | (ppat v pat (begin e0 e ...) (fk)))))) 58 | 59 | (define-syntax ppat 60 | (syntax-rules (? comma unquote) 61 | ((_ v ? kt kf) kt) 62 | ((_ v () kt kf) (if (null? v) kt kf)) 63 | ; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) 64 | ((_ v (unquote var) kt kf) (let ((var v)) kt)) 65 | ((_ v (x . y) kt kf) 66 | (if (pair? v) 67 | (let ((vx (car v)) (vy (cdr v))) 68 | (ppat vx x (ppat vy y kt kf) kf)) 69 | kf)) 70 | ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) 71 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/==-tests.scm: -------------------------------------------------------------------------------- 1 | (test "1" 2 | (run 1 (q) (== 5 q)) 3 | '(5)) 4 | 5 | (test "2" 6 | (run* (q) 7 | (conde 8 | [(== 5 q)] 9 | [(== 6 q)])) 10 | '(5 6)) 11 | 12 | (test "3" 13 | (run* (q) 14 | (fresh (a d) 15 | (conde 16 | [(== 5 a)] 17 | [(== 6 d)]) 18 | (== `(,a . ,d) q))) 19 | '((5 . _.0) (_.0 . 6))) 20 | 21 | (define appendo 22 | (lambda (l s out) 23 | (conde 24 | [(== '() l) (== s out)] 25 | [(fresh (a d res) 26 | (== `(,a . ,d) l) 27 | (== `(,a . ,res) out) 28 | (appendo d s res))]))) 29 | 30 | (test "4" 31 | (run* (q) (appendo '(a b c) '(d e) q)) 32 | '((a b c d e))) 33 | 34 | (test "5" 35 | (run* (q) (appendo q '(d e) '(a b c d e))) 36 | '((a b c))) 37 | 38 | (test "6" 39 | (run* (q) (appendo '(a b c) q '(a b c d e))) 40 | '((d e))) 41 | 42 | (test "7" 43 | (run 5 (q) 44 | (fresh (l s out) 45 | (appendo l s out) 46 | (== `(,l ,s ,out) q))) 47 | '((() _.0 _.0) 48 | ((_.0) _.1 (_.0 . _.1)) 49 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 50 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 51 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 52 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 William E. Byrd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/README.md: -------------------------------------------------------------------------------- 1 | # miniKanren-with-symbolic-constraints 2 | 3 | A revision of https://github.com/webyrd/miniKanren-with-symbolic-constraints/ for better performance. Up to 10x faster for large queries involving heavy use of constraints. 4 | 5 | Includes `==`, `=/=`, `symbolo`, and `numbero`. `absento` is included, but the argument is required to be an eqv-comparable ground atom. 6 | 7 | Eigen was removed. 8 | 9 | ## Running 10 | 11 | ### Racket 12 | 13 | ``` 14 | (require "mk.rkt") 15 | ``` 16 | 17 | ### Vicare 18 | 19 | ``` 20 | (load "mk-vicare.scm") 21 | (load "mk.scm") 22 | ``` 23 | 24 | ## Running Tests 25 | 26 | After loading miniKanren as above, 27 | 28 | ``` 29 | (load "test-all.scm") 30 | ``` 31 | 32 | regardless of scheme implementation. 33 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/absento-closure-tests.scm: -------------------------------------------------------------------------------- 1 | (test "absento 'closure-1a" 2 | (run* (q) (absento 'closure q) (== q 'closure)) 3 | '()) 4 | 5 | (test "absento 'closure-1b" 6 | (run* (q) (== q 'closure) (absento 'closure q)) 7 | '()) 8 | 9 | (test "absento 'closure-2a" 10 | (run* (q) (fresh (a d) (== q 'closure) (absento 'closure q))) 11 | '()) 12 | 13 | (test "absento 'closure-2b" 14 | (run* (q) (fresh (a d) (absento 'closure q) (== q 'closure))) 15 | '()) 16 | 17 | (test "absento 'closure-3a" 18 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q))) 19 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 20 | 21 | (test "absento 'closure-3b" 22 | (run* (q) (fresh (a d) (== `(,a . ,d) q) (absento 'closure q))) 23 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 24 | 25 | (test "absento 'closure-4a" 26 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure a))) 27 | '()) 28 | 29 | (test "absento 'closure-4b" 30 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure a) (== `(,a . ,d) q))) 31 | '()) 32 | 33 | (test "absento 'closure-4c" 34 | (run* (q) (fresh (a d) (== 'closure a) (absento 'closure q) (== `(,a . ,d) q))) 35 | '()) 36 | 37 | (test "absento 'closure-4d" 38 | (run* (q) (fresh (a d) (== 'closure a) (== `(,a . ,d) q) (absento 'closure q))) 39 | '()) 40 | 41 | (test "absento 'closure-5a" 42 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure d))) 43 | '()) 44 | 45 | (test "absento 'closure-5b" 46 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure d) (== `(,a . ,d) q))) 47 | '()) 48 | 49 | (test "absento 'closure-5c" 50 | (run* (q) (fresh (a d) (== 'closure d) (absento 'closure q) (== `(,a . ,d) q))) 51 | '()) 52 | 53 | (test "absento 'closure-5d" 54 | (run* (q) (fresh (a d) (== 'closure d) (== `(,a . ,d) q) (absento 'closure q))) 55 | '()) 56 | 57 | (test "absento 'closure-6" 58 | (run* (q) 59 | (== `(3 (closure x (x x) ((y . 7))) #t) q) 60 | (absento 'closure q)) 61 | '()) 62 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/eval.scm: -------------------------------------------------------------------------------- 1 | (load "mk-vicare.scm") 2 | (load "mk.scm") 3 | (load "numbers.scm") 4 | 5 | (define lookupo 6 | (lambda (x env val) 7 | (fresh (y v env^) 8 | (== `((,y . ,v) . ,env^) env) 9 | (symbolo y) 10 | (conde 11 | [(== x y) (== val v)] 12 | [(=/= x y) 13 | (lookupo x env^ val)])))) 14 | 15 | (define evalo 16 | (lambda (expr env value) 17 | (conde 18 | [(fresh (c) 19 | (== `(const ,c) expr) 20 | (== value c) 21 | (absento 'closure c))] 22 | [(symbolo expr) ; variable 23 | (lookupo expr env value)] 24 | [(fresh (x body) 25 | (== `(lambda (,x) ,body) expr) 26 | (symbolo x) 27 | (== `(closure ,x ,body ,env) value))] 28 | [(fresh (e1 e2 x body env^ arg) 29 | (== `(apply ,e1 ,e2) expr) 30 | (evalo e1 env `(closure ,x ,body ,env^)) 31 | (evalo e2 env arg) 32 | (evalo body `((,x . ,arg) . ,env^) value))] 33 | [(fresh (e1 e2 n1 n2) 34 | (== `(+ ,e1 ,e2) expr) 35 | (evalo e1 env n1) 36 | (evalo e2 env n2) 37 | (pluso n1 n2 value))] 38 | [(fresh (e1 e2 n1 n2) 39 | (== `(* ,e1 ,e2) expr) 40 | (evalo e1 env n1) 41 | (evalo e2 env n2) 42 | (*o n1 n2 value))]))) 43 | 44 | (run* (q) 45 | (evalo `(+ (const ,(build-num 1)) 46 | (const ,(build-num 2))) 47 | '() 48 | q)) 49 | 50 | (run 10 (expr) 51 | (evalo expr 52 | '() 53 | (build-num 3))) 54 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/matche.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "mk.rkt") 3 | (require (for-syntax racket/syntax)) 4 | 5 | (provide matche lambdae defmatche) 6 | 7 | (define-for-syntax memp memf) 8 | 9 | (include "matche.scm") 10 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/matche.scm: -------------------------------------------------------------------------------- 1 | ; new version of matche 2 | ; fixes depth related issues, and works with dots 3 | ; 4 | ; https://github.com/calvis/cKanren/blob/dev/cKanren/matche.rkt#L54 5 | 6 | ; Note that this definition is available at syntax phase in chez and vicare due to implicit 7 | ; phasing, but not in Racket (which uses explicit phasing). Racket already has a version available 8 | ; by default though, so that's fine. This definition isn't just isn't used in Racket. 9 | (define syntax->list 10 | (lambda (e) 11 | (syntax-case e () 12 | [() '()] 13 | [(x . r) (cons #'x (syntax->list #'r))]))) 14 | 15 | (define-syntax defmatche 16 | (lambda (stx) 17 | (syntax-case stx () 18 | [(defmatche (name args ...) clause ...) 19 | #'(define (name args ...) 20 | (matche (args ...) clause ...))]))) 21 | 22 | (define-syntax lambdae 23 | (syntax-rules () 24 | ((_ (x ...) c c* ...) 25 | (lambda (x ...) (matche (x ...) c c* ...))))) 26 | 27 | (define-syntax matche 28 | (lambda (stx) 29 | (syntax-case stx () 30 | [(matche (v ...) ([pat ...] g ...) ...) 31 | (let () 32 | (define remove-duplicates 33 | (lambda (ls eq-pred) 34 | (cond 35 | [(null? ls) '()] 36 | [(memp (lambda (x) (eq-pred (car ls) x)) (cdr ls)) 37 | (remove-duplicates (cdr ls) eq-pred)] 38 | [else (cons (car ls) (remove-duplicates (cdr ls) eq-pred))]))) 39 | (define parse-pattern 40 | (lambda (args pat) 41 | (syntax-case #`(#,args #,pat) () 42 | [(() ()) #'(() () ())] 43 | [((a args ...) [p pat ...]) 44 | (with-syntax ([(p^ (c ...) (x ...)) 45 | (parse-patterns-for-arg #'a #'p)]) 46 | (with-syntax ([([pat^ ...] (c^ ...) (x^ ...)) 47 | (parse-pattern #'(args ...) #'[pat ...])]) 48 | #'([p^ pat^ ...] (c ... c^ ...) (x ... x^ ...))))] 49 | [x (error 'parse-pattern "bad syntax ~s ~s" args pat)]))) 50 | (define parse-patterns-for-arg 51 | (lambda (v pat) 52 | (define loop 53 | (lambda (pat) 54 | (syntax-case pat (unquote ?? ?) ; ?? is the new _, since _ isn't legal in R6 55 | [(unquote ??) 56 | (with-syntax ([_new (generate-temporary #'?_)]) 57 | #'((unquote _new) () (_new)))] 58 | [(unquote x) 59 | (when (free-identifier=? #'x v) 60 | (error 'matche "argument ~s appears in pattern at an invalid depth" 61 | (syntax->datum #'x))) 62 | #'((unquote x) () (x))] 63 | [(unquote (? c x)) 64 | (when (free-identifier=? #'x v) 65 | (error 'matche "argument ~s appears in pattern at an invalid depth" 66 | (syntax->datum #'x))) 67 | #'((unquote x) ((c x)) (x))] 68 | [(a . d) 69 | (with-syntax ([((pat1 (c1 ...) (x1 ...)) 70 | (pat2 (c2 ...) (x2 ...))) 71 | (map loop (syntax->list #'(a d)))]) 72 | #'((pat1 . pat2) (c1 ... c2 ...) (x1 ... x2 ...)))] 73 | [x #'(x () ())]))) 74 | (syntax-case pat (unquote ?) 75 | [(unquote u) 76 | (cond 77 | [(and (identifier? #'u) 78 | (free-identifier=? v #'u)) 79 | #'((unquote u) () ())] 80 | [else (loop pat)])] 81 | [(unquote (? c u)) 82 | (cond 83 | [(and (identifier? #'u) 84 | (free-identifier=? v #'u)) 85 | #'((unquote u) ((c x)) ())] 86 | [else (loop pat)])] 87 | [else (loop pat)]))) 88 | (unless 89 | (andmap (lambda (y) (= (length (syntax->datum #'(v ...))) (length y))) 90 | (syntax->datum #'([pat ...] ...))) 91 | (error 'matche "pattern wrong length blah")) 92 | (with-syntax ([(([pat^ ...] (c ...) (x ...)) ...) 93 | (map (lambda (y) (parse-pattern #'(v ...) y)) 94 | (syntax->list #'([pat ...] ...)))]) 95 | (with-syntax ([((x^ ...) ...) 96 | (map (lambda (ls) 97 | (remove-duplicates (syntax->list ls) free-identifier=?)) 98 | (syntax->list #'((x ...) ...)))]) 99 | (with-syntax ([body 100 | #'(conde 101 | [(fresh (x^ ...) c ... (== `[pat^ ...] ls) g ...)] 102 | ...)]) 103 | #'(let ([ls (list v ...)]) body)))))] 104 | [(matche v (pat g ...) ...) 105 | #'(matche (v) ([pat] g ...) ...)]))) 106 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/mk-vicare.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | 6 | ; Trie implementation, due to Abdulaziz Ghuloum. Used for substitution 7 | ; and constraint store. 8 | 9 | ;;; subst ::= (empty) 10 | ;;; | (node even odd) 11 | ;;; | (data idx val) 12 | 13 | (define-record-type node (fields e o)) 14 | 15 | (define-record-type data (fields idx val)) 16 | 17 | (define shift (lambda (n) (fxsra n 1))) 18 | 19 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 20 | 21 | ;;; interface 22 | 23 | (define t:size 24 | (lambda (x) (t:aux:size x))) 25 | 26 | (define t:bind 27 | (lambda (xi v s) 28 | (unless (and (fixnum? xi) (>= xi 0)) 29 | (error 't:bind "index must be a fixnum, got ~s" xi)) 30 | (t:aux:bind xi v s))) 31 | 32 | (define t:unbind 33 | (lambda (xi s) 34 | (unless (and (fixnum? xi) (>= xi 0)) 35 | (error 't:unbind "index must be a fixnum, got ~s" xi)) 36 | (t:aux:unbind xi s))) 37 | 38 | (define t:lookup 39 | (lambda (xi s) 40 | (unless (and (fixnum? xi) (>= xi 0)) 41 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 42 | (t:aux:lookup xi s))) 43 | 44 | (define t:binding-value 45 | (lambda (s) 46 | (unless (data? s) 47 | (error 't:binding-value "not a binding ~s" s)) 48 | (data-val s))) 49 | 50 | ;;; helpers 51 | 52 | (define t:aux:push 53 | (lambda (xi vi xj vj) 54 | (if (fxeven? xi) 55 | (if (fxeven? xj) 56 | (make-node (t:aux:push (shift xi) vi (shift xj) vj) '()) 57 | (make-node (make-data (shift xi) vi) (make-data (shift xj) vj))) 58 | (if (fxeven? xj) 59 | (make-node (make-data (shift xj) vj) (make-data (shift xi) vi)) 60 | (make-node '() (t:aux:push (shift xi) vi (shift xj) vj)))))) 61 | 62 | (define t:aux:bind 63 | (lambda (xi vi s*) 64 | (cond 65 | [(node? s*) 66 | (if (fxeven? xi) 67 | (make-node (t:aux:bind (shift xi) vi (node-e s*)) (node-o s*)) 68 | (make-node (node-e s*) (t:aux:bind (shift xi) vi (node-o s*))))] 69 | [(data? s*) 70 | (let ([xj (data-idx s*)] [vj (data-val s*)]) 71 | (if (fx= xi xj) 72 | (make-data xi vi) 73 | (t:aux:push xi vi xj vj)))] 74 | [else (make-data xi vi)]))) 75 | 76 | (define t:aux:lookup 77 | (lambda (xi s*) 78 | (cond 79 | [(node? s*) 80 | (if (fxeven? xi) 81 | (t:aux:lookup (shift xi) (node-e s*)) 82 | (t:aux:lookup (shift xi) (node-o s*)))] 83 | [(data? s*) 84 | (if (fx= (data-idx s*) xi) 85 | s* 86 | #f)] 87 | [else #f]))) 88 | 89 | (define t:aux:size 90 | (lambda (s*) 91 | (cond 92 | [(node? s*) (fx+ (t:aux:size (node-e s*)) (t:aux:size (node-o s*)))] 93 | [(data? s*) 1] 94 | [else 0]))) 95 | 96 | (define t:aux:cons^ 97 | (lambda (e o) 98 | (cond 99 | [(or (node? e) (node? o)) (make-node e o)] 100 | [(data? e) 101 | (make-data (unshift (data-idx e) 0) (data-val e))] 102 | [(data? o) 103 | (make-data (unshift (data-idx o) 1) (data-val o))] 104 | [else '()]))) 105 | 106 | (define t:aux:unbind 107 | (lambda (xi s*) 108 | (cond 109 | [(node? s*) 110 | (if (fxeven? xi) 111 | (t:aux:cons^ (t:aux:unbind (shift xi) (node-e s*)) (node-o s*)) 112 | (t:aux:cons^ (node-e s*) (t:aux:unbind (shift xi) (node-o s*))))] 113 | [(and (data? s*) (fx= (data-idx s*) xi)) '()] 114 | [else s*]))) 115 | 116 | 117 | ; Substitution representation 118 | 119 | (define empty-subst-map '()) 120 | 121 | (define subst-map-length t:size) 122 | 123 | ; Returns #f if not found, or a pair of u and the result of the lookup. 124 | ; This distinguishes between #f indicating absence and being the result. 125 | (define subst-map-lookup 126 | (lambda (u S) 127 | (let ((res (t:lookup (var-idx u) S))) 128 | (if res 129 | (data-val res) 130 | unbound)))) 131 | 132 | (define (subst-map-add S var val) 133 | (t:bind (var-idx var) val S)) 134 | 135 | (define subst-map-eq? eq?) 136 | 137 | 138 | ; Alternative (unused) substitution representation, using alists. 139 | ; Performance with the tries is usually about the same and 140 | ; can be much better for huge substitutions. 141 | 142 | #| 143 | (define empty-subst-map '()) 144 | 145 | (define subst-map-length length) 146 | 147 | ; Returns #f if not found, or a pair of u and the result of the lookup. 148 | ; This distinguishes between #f indicating absence and being the result. 149 | (define subst-map-lookup 150 | (lambda (u S) 151 | (let ((res (assq u S))) 152 | (if res 153 | (cdr res) 154 | unbound)))) 155 | 156 | (define (subst-map-add S var val) 157 | (cons (cons var val) S)) 158 | 159 | (define subst-map-eq? eq?) 160 | |# 161 | 162 | 163 | ; Constraint store representation 164 | 165 | (define empty-C '()) 166 | 167 | (define set-c 168 | (lambda (v c st) 169 | (state (state-S st) (t:bind (var-idx v) c (state-C st))))) 170 | 171 | (define lookup-c 172 | (lambda (v st) 173 | (let ((res (t:lookup (var-idx v) (state-C st)))) 174 | (if res 175 | (data-val res) 176 | empty-c)))) 177 | 178 | ; t:unbind either is buggy or doesn't do what I would expect, so 179 | ; I implement remove by setting the value to the empty constraint record. 180 | (define remove-c 181 | (lambda (v st) 182 | (let ((res (t:bind (var-idx v) empty-c (state-C st)))) 183 | (state (state-S st) res)))) 184 | 185 | 186 | ; Misc. missing functions 187 | 188 | (define (remove-duplicates l) 189 | (cond ((null? l) 190 | '()) 191 | ((member (car l) (cdr l)) 192 | (remove-duplicates (cdr l))) 193 | (else 194 | (cons (car l) (remove-duplicates (cdr l)))))) 195 | 196 | (define (foldl f init seq) 197 | (if (null? seq) 198 | init 199 | (foldl f 200 | (f (car seq) init) 201 | (cdr seq)))) 202 | 203 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide run run* 4 | == =/= 5 | fresh 6 | conde 7 | symbolo numbero 8 | absento 9 | (all-defined-out)) 10 | 11 | ;; extra stuff for racket 12 | ;; due mostly to samth 13 | (define (list-sort f l) (sort l f)) 14 | 15 | (define (remp f l) (filter-not f l)) 16 | 17 | (define (call-with-string-output-port f) 18 | (define p (open-output-string)) 19 | (f p) 20 | (get-output-string p)) 21 | 22 | (define (exists f l) (ormap f l)) 23 | 24 | (define for-all andmap) 25 | 26 | (define (find f l) 27 | (cond [(memf f l) => car] [else #f])) 28 | 29 | (define memp memf) 30 | 31 | (define (var*? v) (var? (car v))) 32 | 33 | 34 | ; Substitution representation 35 | 36 | (define empty-subst-map (hasheq)) 37 | 38 | (define subst-map-length hash-count) 39 | 40 | ; Returns #f if not found, or a pair of u and the result of the lookup. 41 | ; This distinguishes between #f indicating absence and being the result. 42 | (define subst-map-lookup 43 | (lambda (u S) 44 | (hash-ref S u unbound))) 45 | 46 | (define (subst-map-add S var val) 47 | (hash-set S var val)) 48 | 49 | (define subst-map-eq? eq?) 50 | 51 | 52 | ; Constraint store representation 53 | 54 | (define empty-C (hasheq)) 55 | 56 | (define set-c 57 | (lambda (v c st) 58 | (state (state-S st) (hash-set (state-C st) v c)))) 59 | 60 | (define lookup-c 61 | (lambda (v st) 62 | (hash-ref (state-C st) v empty-c))) 63 | 64 | (define remove-c 65 | (lambda (v st) 66 | (state (state-S st) (hash-remove (state-C st) v)))) 67 | 68 | 69 | (include "mk.scm") 70 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "numbero-1" 2 | (run* (q) (numbero q)) 3 | '((_.0 (num _.0)))) 4 | 5 | (test "numbero-2" 6 | (run* (q) (numbero q) (== 5 q)) 7 | '(5)) 8 | 9 | (test "numbero-3" 10 | (run* (q) (== 5 q) (numbero q)) 11 | '(5)) 12 | 13 | (test "numbero-4" 14 | (run* (q) (== 'x q) (numbero q)) 15 | '()) 16 | 17 | (test "numbero-5" 18 | (run* (q) (numbero q) (== 'x q)) 19 | '()) 20 | 21 | (test "numbero-6" 22 | (run* (q) (numbero q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "numbero-7" 26 | (run* (q) (== `(1 . 2) q) (numbero q)) 27 | '()) 28 | 29 | (test "numbero-8" 30 | (run* (q) (fresh (x) (numbero x))) 31 | '(_.0)) 32 | 33 | (test "numbero-9" 34 | (run* (q) (fresh (x) (numbero x))) 35 | '(_.0)) 36 | 37 | (test "numbero-10" 38 | (run* (q) (fresh (x) (numbero x) (== x q))) 39 | '((_.0 (num _.0)))) 40 | 41 | (test "numbero-11" 42 | (run* (q) (fresh (x) (numbero q) (== x q) (numbero x))) 43 | '((_.0 (num _.0)))) 44 | 45 | (test "numbero-12" 46 | (run* (q) (fresh (x) (numbero q) (numbero x) (== x q))) 47 | '((_.0 (num _.0)))) 48 | 49 | (test "numbero-13" 50 | (run* (q) (fresh (x) (== x q) (numbero q) (numbero x))) 51 | '((_.0 (num _.0)))) 52 | 53 | (test "numbero-14-a" 54 | (run* (q) (fresh (x) (numbero q) (== 5 x))) 55 | '((_.0 (num _.0)))) 56 | 57 | (test "numbero-14-b" 58 | (run* (q) (fresh (x) (numbero q) (== 5 x) (== x q))) 59 | '(5)) 60 | 61 | (test "numbero-15" 62 | (run* (q) (fresh (x) (== q x) (numbero q) (== 'y x))) 63 | '()) 64 | 65 | (test "numbero-16-a" 66 | (run* (q) (numbero q) (=/= 'y q)) 67 | '((_.0 (num _.0)))) 68 | 69 | (test "numbero-16-b" 70 | (run* (q) (=/= 'y q) (numbero q)) 71 | '((_.0 (num _.0)))) 72 | 73 | (test "numbero-17" 74 | (run* (q) (numbero q) (=/= `(1 . 2) q)) 75 | '((_.0 (num _.0)))) 76 | 77 | (test "numbero-18" 78 | (run* (q) (numbero q) (=/= 5 q)) 79 | '((_.0 (=/= ((_.0 5))) (num _.0)))) 80 | 81 | (test "numbero-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (numbero x) 85 | (numbero y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (num _.0 _.1)))) 88 | 89 | (test "numbero-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (numbero x) 94 | (numbero y))) 95 | '(((_.0 _.1) (num _.0 _.1)))) 96 | 97 | (test "numbero-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (numbero x) 102 | (numbero x))) 103 | '(((_.0 _.1) (num _.0)))) 104 | 105 | (test "numbero-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (numbero x) 109 | (numbero x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (num _.0)))) 112 | 113 | (test "numbero-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (numbero x) 117 | (== `(,x ,y) q) 118 | (numbero x))) 119 | '(((_.0 _.1) (num _.0)))) 120 | 121 | (test "numbero-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (numbero w) 126 | (numbero z))) 127 | '(_.0)) 128 | 129 | (test "numbero-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (numbero w) 134 | (numbero z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (num _.0 _.3)))) 139 | 140 | (test "numbero-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (numbero w) 145 | (numbero y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (num _.0 _.2)))) 150 | 151 | (test "numbero-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (numbero w) 156 | (numbero y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (num _.0)))) 162 | 163 | (test "numbero-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(a . b)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 a) (_.1 b)))))) 169 | 170 | (test "numbero-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(a . b)) 174 | (numbero w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (num _.0)))) 177 | 178 | (test "numbero-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (numbero w) 182 | (=/= `(,w . ,x) `(a . b)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (num _.0)))) 185 | 186 | (test "numbero-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (numbero w) 190 | (=/= `(a . b) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (num _.0)))) 193 | 194 | (test "numbero-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (numbero w) 198 | (=/= `(a . ,x) `(,w . b)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (num _.0)))) 201 | 202 | (test "numbero-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (numbero w) 206 | (=/= `(5 . ,x) `(,w . b)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 b))) (num _.0)))) 209 | 210 | (test "numbero-31" 211 | (run* (q) 212 | (fresh (x y z a b) 213 | (numbero x) 214 | (numbero y) 215 | (numbero z) 216 | (numbero a) 217 | (numbero b) 218 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 219 | (== q `(,x ,y ,z ,a ,b)))) 220 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 221 | 222 | (test "numbero-32" 223 | (run* (q) 224 | (fresh (x y z a b) 225 | (== q `(,x ,y ,z ,a ,b)) 226 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 227 | (numbero x) 228 | (numbero a))) 229 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 230 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/simple-interp.scm: -------------------------------------------------------------------------------- 1 | (define evalo 2 | (lambda (expr val) 3 | (eval-expro expr '() val))) 4 | 5 | (define eval-expro 6 | (lambda (expr env val) 7 | (conde 8 | ((fresh (rator rand x body env^ a) 9 | (== `(,rator ,rand) expr) 10 | (eval-expro rator env `(closure ,x ,body ,env^)) 11 | (eval-expro rand env a) 12 | (eval-expro body `((,x . ,a) . ,env^) val))) 13 | ((fresh (x body) 14 | (== `(lambda (,x) ,body) expr) 15 | (symbolo x) 16 | (== `(closure ,x ,body ,env) val) 17 | (not-in-envo 'lambda env))) 18 | ((symbolo expr) (lookupo expr env val))))) 19 | 20 | (define not-in-envo 21 | (lambda (x env) 22 | (conde 23 | ((== '() env)) 24 | ((fresh (y v rest) 25 | (== `((,y . ,v) . ,rest) env) 26 | (=/= y x) 27 | (not-in-envo x rest)))))) 28 | 29 | (define lookupo 30 | (lambda (x env t) 31 | (conde 32 | ((fresh (y v rest) 33 | (== `((,y . ,v) . ,rest) env) (== y x) 34 | (== v t))) 35 | ((fresh (y v rest) 36 | (== `((,y . ,v) . ,rest) env) (=/= y x) 37 | (lookupo x rest t)))))) 38 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/symbolo-numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-numbero-1" 2 | (run* (q) (symbolo q) (numbero q)) 3 | '()) 4 | 5 | (test "symbolo-numbero-2" 6 | (run* (q) (numbero q) (symbolo q)) 7 | '()) 8 | 9 | (test "symbolo-numbero-3" 10 | (run* (q) 11 | (fresh (x) 12 | (numbero x) 13 | (symbolo x))) 14 | '()) 15 | 16 | (test "symbolo-numbero-4" 17 | (run* (q) 18 | (fresh (x) 19 | (symbolo x) 20 | (numbero x))) 21 | '()) 22 | 23 | (test "symbolo-numbero-5" 24 | (run* (q) 25 | (numbero q) 26 | (fresh (x) 27 | (symbolo x) 28 | (== x q))) 29 | '()) 30 | 31 | (test "symbolo-numbero-6" 32 | (run* (q) 33 | (symbolo q) 34 | (fresh (x) 35 | (numbero x) 36 | (== x q))) 37 | '()) 38 | 39 | (test "symbolo-numbero-7" 40 | (run* (q) 41 | (fresh (x) 42 | (numbero x) 43 | (== x q)) 44 | (symbolo q)) 45 | '()) 46 | 47 | (test "symbolo-numbero-7" 48 | (run* (q) 49 | (fresh (x) 50 | (symbolo x) 51 | (== x q)) 52 | (numbero q)) 53 | '()) 54 | 55 | (test "symbolo-numbero-8" 56 | (run* (q) 57 | (fresh (x) 58 | (== x q) 59 | (symbolo x)) 60 | (numbero q)) 61 | '()) 62 | 63 | (test "symbolo-numbero-9" 64 | (run* (q) 65 | (fresh (x) 66 | (== x q) 67 | (numbero x)) 68 | (symbolo q)) 69 | '()) 70 | 71 | (test "symbolo-numbero-10" 72 | (run* (q) 73 | (symbolo q) 74 | (fresh (x) 75 | (numbero x))) 76 | '((_.0 (sym _.0)))) 77 | 78 | (test "symbolo-numbero-11" 79 | (run* (q) 80 | (numbero q) 81 | (fresh (x) 82 | (symbolo x))) 83 | '((_.0 (num _.0)))) 84 | 85 | (test "symbolo-numbero-12" 86 | (run* (q) 87 | (fresh (x y) 88 | (symbolo x) 89 | (== `(,x ,y) q))) 90 | '(((_.0 _.1) (sym _.0)))) 91 | 92 | (test "symbolo-numbero-13" 93 | (run* (q) 94 | (fresh (x y) 95 | (numbero x) 96 | (== `(,x ,y) q))) 97 | '(((_.0 _.1) (num _.0)))) 98 | 99 | (test "symbolo-numbero-14" 100 | (run* (q) 101 | (fresh (x y) 102 | (numbero x) 103 | (symbolo y) 104 | (== `(,x ,y) q))) 105 | '(((_.0 _.1) (num _.0) (sym _.1)))) 106 | 107 | (test "symbolo-numbero-15" 108 | (run* (q) 109 | (fresh (x y) 110 | (numbero x) 111 | (== `(,x ,y) q) 112 | (symbolo y))) 113 | '(((_.0 _.1) (num _.0) (sym _.1)))) 114 | 115 | (test "symbolo-numbero-16" 116 | (run* (q) 117 | (fresh (x y) 118 | (== `(,x ,y) q) 119 | (numbero x) 120 | (symbolo y))) 121 | '(((_.0 _.1) (num _.0) (sym _.1)))) 122 | 123 | (test "symbolo-numbero-17" 124 | (run* (q) 125 | (fresh (x y) 126 | (== `(,x ,y) q) 127 | (numbero x) 128 | (symbolo y)) 129 | (fresh (w z) 130 | (== `(,w ,z) q))) 131 | '(((_.0 _.1) (num _.0) (sym _.1)))) 132 | 133 | (test "symbolo-numbero-18" 134 | (run* (q) 135 | (fresh (x y) 136 | (== `(,x ,y) q) 137 | (numbero x) 138 | (symbolo y)) 139 | (fresh (w z) 140 | (== `(,w ,z) q) 141 | (== w 5))) 142 | '(((5 _.0) (sym _.0)))) 143 | 144 | (test "symbolo-numbero-19" 145 | (run* (q) 146 | (fresh (x y) 147 | (== `(,x ,y) q) 148 | (numbero x) 149 | (symbolo y)) 150 | (fresh (w z) 151 | (== 'a z) 152 | (== `(,w ,z) q))) 153 | '(((_.0 a) (num _.0)))) 154 | 155 | (test "symbolo-numbero-20" 156 | (run* (q) 157 | (fresh (x y) 158 | (== `(,x ,y) q) 159 | (numbero x) 160 | (symbolo y)) 161 | (fresh (w z) 162 | (== `(,w ,z) q) 163 | (== 'a z))) 164 | '(((_.0 a) (num _.0)))) 165 | 166 | (test "symbolo-numbero-21" 167 | (run* (q) 168 | (fresh (x y) 169 | (== `(,x ,y) q) 170 | (=/= `(5 a) q))) 171 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 a)))))) 172 | 173 | (test "symbolo-numbero-22" 174 | (run* (q) 175 | (fresh (x y) 176 | (== `(,x ,y) q) 177 | (=/= `(5 a) q) 178 | (symbolo x))) 179 | '(((_.0 _.1) (sym _.0)))) 180 | 181 | (test "symbolo-numbero-23" 182 | (run* (q) 183 | (fresh (x y) 184 | (== `(,x ,y) q) 185 | (symbolo x) 186 | (=/= `(5 a) q))) 187 | '(((_.0 _.1) (sym _.0)))) 188 | 189 | (test "symbolo-numbero-24" 190 | (run* (q) 191 | (fresh (x y) 192 | (symbolo x) 193 | (== `(,x ,y) q) 194 | (=/= `(5 a) q))) 195 | '(((_.0 _.1) (sym _.0)))) 196 | 197 | (test "symbolo-numbero-25" 198 | (run* (q) 199 | (fresh (x y) 200 | (=/= `(5 a) q) 201 | (symbolo x) 202 | (== `(,x ,y) q))) 203 | '(((_.0 _.1) (sym _.0)))) 204 | 205 | (test "symbolo-numbero-26" 206 | (run* (q) 207 | (fresh (x y) 208 | (=/= `(5 a) q) 209 | (== `(,x ,y) q) 210 | (symbolo x))) 211 | '(((_.0 _.1) (sym _.0)))) 212 | 213 | (test "symbolo-numbero-27" 214 | (run* (q) 215 | (fresh (x y) 216 | (== `(,x ,y) q) 217 | (=/= `(5 a) q) 218 | (numbero y))) 219 | '(((_.0 _.1) (num _.1)))) 220 | 221 | (test "symbolo-numbero-28" 222 | (run* (q) 223 | (fresh (x y) 224 | (== `(,x ,y) q) 225 | (numbero y) 226 | (=/= `(5 a) q))) 227 | '(((_.0 _.1) (num _.1)))) 228 | 229 | (test "symbolo-numbero-29" 230 | (run* (q) 231 | (fresh (x y) 232 | (numbero y) 233 | (== `(,x ,y) q) 234 | (=/= `(5 a) q))) 235 | '(((_.0 _.1) (num _.1)))) 236 | 237 | (test "symbolo-numbero-30" 238 | (run* (q) 239 | (fresh (x y) 240 | (=/= `(5 a) q) 241 | (numbero y) 242 | (== `(,x ,y) q))) 243 | '(((_.0 _.1) (num _.1)))) 244 | 245 | (test "symbolo-numbero-31" 246 | (run* (q) 247 | (fresh (x y) 248 | (=/= `(5 a) q) 249 | (== `(,x ,y) q) 250 | (numbero y))) 251 | '(((_.0 _.1) (num _.1)))) 252 | 253 | (test "symbolo-numbero-32" 254 | (run* (q) 255 | (fresh (x y) 256 | (=/= `(,x ,y) q) 257 | (numbero x) 258 | (symbolo y))) 259 | '(_.0)) 260 | 261 | (test "symbolo-numbero-33" 262 | (run* (q) 263 | (fresh (x y) 264 | (numbero x) 265 | (=/= `(,x ,y) q) 266 | (symbolo y))) 267 | '(_.0)) 268 | 269 | (test "symbolo-numbero-34" 270 | (run* (q) 271 | (fresh (x y) 272 | (numbero x) 273 | (symbolo y) 274 | (=/= `(,x ,y) q))) 275 | '(_.0)) 276 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/symbolo-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-1" 2 | (run* (q) (symbolo q)) 3 | '((_.0 (sym _.0)))) 4 | 5 | (test "symbolo-2" 6 | (run* (q) (symbolo q) (== 'x q)) 7 | '(x)) 8 | 9 | (test "symbolo-3" 10 | (run* (q) (== 'x q) (symbolo q)) 11 | '(x)) 12 | 13 | (test "symbolo-4" 14 | (run* (q) (== 5 q) (symbolo q)) 15 | '()) 16 | 17 | (test "symbolo-5" 18 | (run* (q) (symbolo q) (== 5 q)) 19 | '()) 20 | 21 | (test "symbolo-6" 22 | (run* (q) (symbolo q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "symbolo-7" 26 | (run* (q) (== `(1 . 2) q) (symbolo q)) 27 | '()) 28 | 29 | (test "symbolo-8" 30 | (run* (q) (fresh (x) (symbolo x))) 31 | '(_.0)) 32 | 33 | (test "symbolo-9" 34 | (run* (q) (fresh (x) (symbolo x))) 35 | '(_.0)) 36 | 37 | (test "symbolo-10" 38 | (run* (q) (fresh (x) (symbolo x) (== x q))) 39 | '((_.0 (sym _.0)))) 40 | 41 | (test "symbolo-11" 42 | (run* (q) (fresh (x) (symbolo q) (== x q) (symbolo x))) 43 | '((_.0 (sym _.0)))) 44 | 45 | (test "symbolo-12" 46 | (run* (q) (fresh (x) (symbolo q) (symbolo x) (== x q))) 47 | '((_.0 (sym _.0)))) 48 | 49 | (test "symbolo-13" 50 | (run* (q) (fresh (x) (== x q) (symbolo q) (symbolo x))) 51 | '((_.0 (sym _.0)))) 52 | 53 | (test "symbolo-14-a" 54 | (run* (q) (fresh (x) (symbolo q) (== 'y x))) 55 | '((_.0 (sym _.0)))) 56 | 57 | (test "symbolo-14-b" 58 | (run* (q) (fresh (x) (symbolo q) (== 'y x) (== x q))) 59 | '(y)) 60 | 61 | (test "symbolo-15" 62 | (run* (q) (fresh (x) (== q x) (symbolo q) (== 5 x))) 63 | '()) 64 | 65 | (test "symbolo-16-a" 66 | (run* (q) (symbolo q) (=/= 5 q)) 67 | '((_.0 (sym _.0)))) 68 | 69 | (test "symbolo-16-b" 70 | (run* (q) (=/= 5 q) (symbolo q)) 71 | '((_.0 (sym _.0)))) 72 | 73 | (test "symbolo-17" 74 | (run* (q) (symbolo q) (=/= `(1 . 2) q)) 75 | '((_.0 (sym _.0)))) 76 | 77 | (test "symbolo-18" 78 | (run* (q) (symbolo q) (=/= 'y q)) 79 | '((_.0 (=/= ((_.0 y))) (sym _.0)))) 80 | 81 | (test "symbolo-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (symbolo x) 85 | (symbolo y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (sym _.0 _.1)))) 88 | 89 | (test "symbolo-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (symbolo x) 94 | (symbolo y))) 95 | '(((_.0 _.1) (sym _.0 _.1)))) 96 | 97 | (test "symbolo-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (symbolo x) 102 | (symbolo x))) 103 | '(((_.0 _.1) (sym _.0)))) 104 | 105 | (test "symbolo-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (symbolo x) 109 | (symbolo x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (sym _.0)))) 112 | 113 | (test "symbolo-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (symbolo x) 117 | (== `(,x ,y) q) 118 | (symbolo x))) 119 | '(((_.0 _.1) (sym _.0)))) 120 | 121 | (test "symbolo-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (symbolo w) 126 | (symbolo z))) 127 | '(_.0)) 128 | 129 | (test "symbolo-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (symbolo w) 134 | (symbolo z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (sym _.0 _.3)))) 139 | 140 | (test "symbolo-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (symbolo w) 145 | (symbolo y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (sym _.0 _.2)))) 150 | 151 | (test "symbolo-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (symbolo w) 156 | (symbolo y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (sym _.0)))) 162 | 163 | (test "symbolo-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(5 . 6)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 6)))))) 169 | 170 | (test "symbolo-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(5 . 6)) 174 | (symbolo w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (sym _.0)))) 177 | 178 | (test "symbolo-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (symbolo w) 182 | (=/= `(,w . ,x) `(5 . 6)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (sym _.0)))) 185 | 186 | (test "symbolo-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (symbolo w) 190 | (=/= `(5 . 6) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (sym _.0)))) 193 | 194 | (test "symbolo-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (symbolo w) 198 | (=/= `(5 . ,x) `(,w . 6)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (sym _.0)))) 201 | 202 | (test "symbolo-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (symbolo w) 206 | (=/= `(z . ,x) `(,w . 6)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 z) (_.1 6))) (sym _.0)))) 209 | 210 | (test "symbolo-31-a" 211 | (run* (q) 212 | (fresh (w x y z) 213 | (== x 5) 214 | (=/= `(,w ,y) `(,x ,z)) 215 | (== w 5) 216 | (== `(,w ,x ,y ,z) q))) 217 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 218 | 219 | (test "symbolo-31-b" 220 | (run* (q) 221 | (fresh (w x y z) 222 | (=/= `(,w ,y) `(,x ,z)) 223 | (== w 5) 224 | (== x 5) 225 | (== `(,w ,x ,y ,z) q))) 226 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 227 | 228 | (test "symbolo-31-c" 229 | (run* (q) 230 | (fresh (w x y z) 231 | (== w 5) 232 | (=/= `(,w ,y) `(,x ,z)) 233 | (== `(,w ,x ,y ,z) q) 234 | (== x 5))) 235 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 236 | 237 | (test "symbolo-31-d" 238 | (run* (q) 239 | (fresh (w x y z) 240 | (== w 5) 241 | (== x 5) 242 | (=/= `(,w ,y) `(,x ,z)) 243 | (== `(,w ,x ,y ,z) q))) 244 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 245 | 246 | 247 | (test "symbolo-32-a" 248 | (run* (q) 249 | (fresh (w x y z) 250 | (== x 'a) 251 | (=/= `(,w ,y) `(,x ,z)) 252 | (== w 'a) 253 | (== `(,w ,x ,y ,z) q))) 254 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 255 | 256 | (test "symbolo-32-b" 257 | (run* (q) 258 | (fresh (w x y z) 259 | (=/= `(,w ,y) `(,x ,z)) 260 | (== w 'a) 261 | (== x 'a) 262 | (== `(,w ,x ,y ,z) q))) 263 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 264 | 265 | (test "symbolo-32-c" 266 | (run* (q) 267 | (fresh (w x y z) 268 | (== w 'a) 269 | (=/= `(,w ,y) `(,x ,z)) 270 | (== `(,w ,x ,y ,z) q) 271 | (== x 'a))) 272 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 273 | 274 | (test "symbolo-32-d" 275 | (run* (q) 276 | (fresh (w x y z) 277 | (== w 'a) 278 | (== x 'a) 279 | (=/= `(,w ,y) `(,x ,z)) 280 | (== `(,w ,x ,y ,z) q))) 281 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 282 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/test-all.scm: -------------------------------------------------------------------------------- 1 | (load "test-check.scm") 2 | 3 | (printf "==-tests\n") 4 | (load "==-tests.scm") 5 | 6 | (printf "symbolo-tests\n") 7 | (load "symbolo-tests.scm") 8 | 9 | (printf "numbero-tests\n") 10 | (load "numbero-tests.scm") 11 | 12 | (printf "symbolo-numbero-tests\n") 13 | (load "symbolo-numbero-tests.scm") 14 | 15 | (printf "disequality-tests\n") 16 | (load "disequality-tests.scm") 17 | 18 | (printf "absento-closure-tests\n") 19 | (load "absento-closure-tests.scm") 20 | 21 | (printf "absento-tests\n") 22 | (load "absento-tests.scm") 23 | 24 | (printf "test-infer\n") 25 | (load "test-infer.scm") 26 | 27 | (printf "test-simple-interp\n") 28 | (load "test-simple-interp.scm") 29 | 30 | (printf "test-quines\n") 31 | (load "test-quines.scm") 32 | 33 | (printf "test-numbers\n") 34 | (load "numbers.scm") 35 | (load "test-numbers.scm") 36 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/test-infer.scm: -------------------------------------------------------------------------------- 1 | (define !- 2 | (lambda (exp env t) 3 | (conde 4 | [(symbolo exp) (lookupo exp env t)] 5 | [(fresh (x e t-x t-e) 6 | (== `(lambda (,x) ,e) exp) 7 | (symbolo x) 8 | (not-in-envo 'lambda env) 9 | (== `(-> ,t-x ,t-e) t) 10 | (!- e `((,x . ,t-x) . ,env) t-e))] 11 | [(fresh (rator rand t-x) 12 | (== `(,rator ,rand) exp) 13 | (!- rator env `(-> ,t-x ,t)) 14 | (!- rand env t-x))]))) 15 | 16 | (define lookupo 17 | (lambda (x env t) 18 | (fresh (rest y v) 19 | (== `((,y . ,v) . ,rest) env) 20 | (conde 21 | ((== y x) (== v t)) 22 | ((=/= y x) (lookupo x rest t)))))) 23 | 24 | (define not-in-envo 25 | (lambda (x env) 26 | (conde 27 | ((== '() env)) 28 | ((fresh (y v rest) 29 | (== `((,y . ,v) . ,rest) env) 30 | (=/= y x) 31 | (not-in-envo x rest)))))) 32 | 33 | (test "types" 34 | (run 10 (q) (fresh (t exp) (!- exp '() t) (== `(,exp => ,t) q))) 35 | '((((lambda (_.0) _.0) => (-> _.1 _.1)) (sym _.0)) 36 | (((lambda (_.0) (lambda (_.1) _.1)) 37 | => 38 | (-> _.2 (-> _.3 _.3))) 39 | (=/= ((_.0 lambda))) 40 | (sym _.0 _.1)) 41 | (((lambda (_.0) (lambda (_.1) _.0)) 42 | => 43 | (-> _.2 (-> _.3 _.2))) 44 | (=/= ((_.0 _.1)) ((_.0 lambda))) 45 | (sym _.0 _.1)) 46 | ((((lambda (_.0) _.0) (lambda (_.1) _.1)) => (-> _.2 _.2)) 47 | (sym _.0 _.1)) 48 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.2))) 49 | => 50 | (-> _.3 (-> _.4 (-> _.5 _.5)))) 51 | (=/= ((_.0 lambda)) ((_.1 lambda))) 52 | (sym _.0 _.1 _.2)) 53 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.1))) 54 | => 55 | (-> _.3 (-> _.4 (-> _.5 _.4)))) 56 | (=/= ((_.0 lambda)) ((_.1 _.2)) ((_.1 lambda))) 57 | (sym _.0 _.1 _.2)) 58 | (((lambda (_.0) (_.0 (lambda (_.1) _.1))) 59 | => 60 | (-> (-> (-> _.2 _.2) _.3) _.3)) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1)) 63 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.0))) 64 | => 65 | (-> _.3 (-> _.4 (-> _.5 _.3)))) 66 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 lambda)) ((_.1 lambda))) 67 | (sym _.0 _.1 _.2)) 68 | (((lambda (_.0) (lambda (_.1) (_.1 _.0))) 69 | => 70 | (-> _.2 (-> (-> _.2 _.3) _.3))) 71 | (=/= ((_.0 _.1)) ((_.0 lambda))) 72 | (sym _.0 _.1)) 73 | ((((lambda (_.0) _.0) (lambda (_.1) (lambda (_.2) _.2))) 74 | => 75 | (-> _.3 (-> _.4 _.4))) 76 | (=/= ((_.1 lambda))) 77 | (sym _.0 _.1 _.2)))) 78 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/test-numbers.scm: -------------------------------------------------------------------------------- 1 | (test "test 1" 2 | (run* (q) (*o (build-num 2) (build-num 3) q)) 3 | '((0 1 1))) 4 | 5 | (test "test 2" 6 | (run* (q) 7 | (fresh (n m) 8 | (*o n m (build-num 6)) 9 | (== `(,n ,m) q))) 10 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 11 | 12 | (test "sums" 13 | (run 5 (q) 14 | (fresh (x y z) 15 | (pluso x y z) 16 | (== `(,x ,y ,z) q))) 17 | '((_.0 () _.0) 18 | (() (_.0 . _.1) (_.0 . _.1)) 19 | ((1) (1) (0 1)) 20 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 21 | ((1) (1 1) (0 0 1)))) 22 | 23 | (test "factors" 24 | (run* (q) 25 | (fresh (x y) 26 | (*o x y (build-num 24)) 27 | (== `(,x ,y ,(build-num 24)) q))) 28 | '(((1) (0 0 0 1 1) (0 0 0 1 1)) 29 | ((0 0 0 1 1) (1) (0 0 0 1 1)) 30 | ((0 1) (0 0 1 1) (0 0 0 1 1)) 31 | ((0 0 1) (0 1 1) (0 0 0 1 1)) 32 | ((0 0 0 1) (1 1) (0 0 0 1 1)) 33 | ((1 1) (0 0 0 1) (0 0 0 1 1)) 34 | ((0 1 1) (0 0 1) (0 0 0 1 1)) 35 | ((0 0 1 1) (0 1) (0 0 0 1 1)))) 36 | 37 | (define number-primo 38 | (lambda (exp env val) 39 | (fresh (n) 40 | (== `(intexp ,n) exp) 41 | (== `(intval ,n) val) 42 | (not-in-envo 'numo env)))) 43 | 44 | (define sub1-primo 45 | (lambda (exp env val) 46 | (fresh (e n n-1) 47 | (== `(sub1 ,e) exp) 48 | (== `(intval ,n-1) val) 49 | (not-in-envo 'sub1 env) 50 | (eval-expo e env `(intval ,n)) 51 | (minuso n '(1) n-1)))) 52 | 53 | (define zero?-primo 54 | (lambda (exp env val) 55 | (fresh (e n) 56 | (== `(zero? ,e) exp) 57 | (conde 58 | ((zeroo n) (== #t val)) 59 | ((poso n) (== #f val))) 60 | (not-in-envo 'zero? env) 61 | (eval-expo e env `(intval ,n))))) 62 | 63 | (define *-primo 64 | (lambda (exp env val) 65 | (fresh (e1 e2 n1 n2 n3) 66 | (== `(* ,e1 ,e2) exp) 67 | (== `(intval ,n3) val) 68 | (not-in-envo '* env) 69 | (eval-expo e1 env `(intval ,n1)) 70 | (eval-expo e2 env `(intval ,n2)) 71 | (*o n1 n2 n3)))) 72 | 73 | (define if-primo 74 | (lambda (exp env val) 75 | (fresh (e1 e2 e3 t) 76 | (== `(if ,e1 ,e2 ,e3) exp) 77 | (not-in-envo 'if env) 78 | (eval-expo e1 env t) 79 | (conde 80 | ((== #t t) (eval-expo e2 env val)) 81 | ((== #f t) (eval-expo e3 env val)))))) 82 | 83 | (define boolean-primo 84 | (lambda (exp env val) 85 | (conde 86 | ((== #t exp) (== #t val)) 87 | ((== #f exp) (== #f val))))) 88 | 89 | (define eval-expo 90 | (lambda (exp env val) 91 | (conde 92 | ((boolean-primo exp env val)) 93 | ((number-primo exp env val)) 94 | ((sub1-primo exp env val)) 95 | ((zero?-primo exp env val)) 96 | ((*-primo exp env val)) 97 | ((if-primo exp env val)) 98 | ((symbolo exp) (lookupo exp env val)) 99 | ((fresh (rator rand x body env^ a) 100 | (== `(,rator ,rand) exp) 101 | (eval-expo rator env `(closure ,x ,body ,env^)) 102 | (eval-expo rand env a) 103 | (eval-expo body `((,x . ,a) . ,env^) val))) 104 | ((fresh (x body) 105 | (== `(lambda (,x) ,body) exp) 106 | (symbolo x) 107 | (== `(closure ,x ,body ,env) val) 108 | (not-in-envo 'lambda env)))))) 109 | 110 | (define not-in-envo 111 | (lambda (x env) 112 | (conde 113 | ((fresh (y v rest) 114 | (== `((,y . ,v) . ,rest) env) 115 | (=/= y x) 116 | (not-in-envo x rest))) 117 | ((== '() env))))) 118 | 119 | (define lookupo 120 | (lambda (x env t) 121 | (fresh (rest y v) 122 | (== `((,y . ,v) . ,rest) env) 123 | (conde 124 | ((== y x) (== v t)) 125 | ((=/= y x) (lookupo x rest t)))))) 126 | 127 | (test "push-down problems 2" 128 | (run* (q) 129 | (fresh (x a d) 130 | (absento 'intval x) 131 | (== 'intval a) 132 | (== `(,a . ,d) x))) 133 | '()) 134 | 135 | (test "push-down problems 3" 136 | (run* (q) 137 | (fresh (x a d) 138 | (== `(,a . ,d) x) 139 | (absento 'intval x) 140 | (== 'intval a))) 141 | '()) 142 | 143 | (test "push-down problems 4" 144 | (run* (q) 145 | (fresh (x a d) 146 | (== `(,a . ,d) x) 147 | (== 'intval a) 148 | (absento 'intval x))) 149 | '()) 150 | 151 | (test "push-down problems 6" 152 | (run* (q) 153 | (fresh (x a d) 154 | (== 'intval a) 155 | (== `(,a . ,d) x) 156 | (absento 'intval x))) 157 | '()) 158 | 159 | (test "push-down problems 1" 160 | (run* (q) 161 | (fresh (x a d) 162 | (absento 'intval x) 163 | (== `(,a . ,d) x) 164 | (== 'intval a))) 165 | '()) 166 | 167 | (test "push-down problems 5" 168 | (run* (q) 169 | (fresh (x a d) 170 | (== 'intval a) 171 | (absento 'intval x) 172 | (== `(,a . ,d) x))) 173 | '()) 174 | 175 | (test "zero?" 176 | (run 1 (q) 177 | (eval-expo `(zero? (sub1 (intexp ,(build-num 1)))) '() q)) 178 | '(#t)) 179 | 180 | (test "*" 181 | (run 1 (q) 182 | (eval-expo `(* (intexp ,(build-num 3)) (intexp ,(build-num 2))) '() `(intval ,(build-num 6)))) 183 | '(_.0)) 184 | 185 | (test "sub1" 186 | (run 1 (q) 187 | (eval-expo q '() `(intval ,(build-num 6))) (== `(sub1 (intexp ,(build-num 7))) q)) 188 | '((sub1 (intexp (1 1 1))))) 189 | 190 | (test "sub1 bigger WAIT a minute" 191 | (run 1 (q) 192 | (eval-expo q '() `(intval ,(build-num 6))) 193 | (== `(sub1 (sub1 (intexp ,(build-num 8)))) q)) 194 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 195 | 196 | (test "sub1 biggest WAIT a minute" 197 | (run 1 (q) 198 | (eval-expo q '() `(intval ,(build-num 6))) 199 | (== `(sub1 (sub1 (sub1 (intexp ,(build-num 9))))) q)) 200 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 201 | 202 | (test "lots of programs to make a 6" 203 | (run 12 (q) (eval-expo q '() `(intval ,(build-num 6)))) 204 | '((intexp (0 1 1)) (sub1 (intexp (1 1 1))) 205 | (* (intexp (1)) (intexp (0 1 1))) 206 | (* (intexp (0 1 1)) (intexp (1))) 207 | (if #t (intexp (0 1 1)) _.0) 208 | (* (intexp (0 1)) (intexp (1 1))) 209 | (if #f _.0 (intexp (0 1 1))) 210 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 211 | (((lambda (_.0) (intexp (0 1 1))) #t) 212 | (=/= ((_.0 numo))) 213 | (sym _.0)) 214 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 215 | (sub1 (sub1 (intexp (0 0 0 1)))) 216 | (sub1 (if #t (intexp (1 1 1)) _.0)))) 217 | 218 | (define rel-fact5 219 | `((lambda (f) 220 | ((f f) (intexp ,(build-num 5)))) 221 | (lambda (f) 222 | (lambda (n) 223 | (if (zero? n) 224 | (intexp ,(build-num 1)) 225 | (* n ((f f) (sub1 n)))))))) 226 | 227 | (test "rel-fact5" 228 | (run* (q) (eval-expo rel-fact5 '() q)) 229 | `((intval ,(build-num 120)))) 230 | 231 | (test "rel-fact5-backwards" 232 | (run 1 (q) 233 | (eval-expo 234 | `((lambda (f) 235 | ((f ,q) (intexp ,(build-num 5)))) 236 | (lambda (f) 237 | (lambda (n) 238 | (if (zero? n) 239 | (intexp ,(build-num 1)) 240 | (* n ((f f) (sub1 n))))))) 241 | '() 242 | `(intval ,(build-num 120)))) 243 | `(f)) 244 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/faster-miniKanren/test-simple-interp.scm: -------------------------------------------------------------------------------- 1 | (load "simple-interp.scm") 2 | 3 | (test "running backwards" 4 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 5 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 6 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 7 | (((lambda (x) (lambda (y) x)) 8 | ((lambda (_.0) _.0) (lambda (z) z))) 9 | (sym _.0)) 10 | (((lambda (_.0) _.0) 11 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 12 | (sym _.0)) 13 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 14 | (lambda (z) z)) 15 | (sym _.0)))) 16 | 17 | (define lookupo 18 | (lambda (x env t) 19 | (fresh (rest y v) 20 | (== `((,y . ,v) . ,rest) env) 21 | (conde 22 | ((== y x) (== v t)) 23 | ((=/= y x) (lookupo x rest t)))))) 24 | 25 | (test "eval-exp-lc 1" 26 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) (lambda (z) z)) (lambda (a) a)) q)) 27 | '((closure z z ()))) 28 | 29 | (test "eval-exp-lc 2" 30 | (run* (q) (evalo '((lambda (x) (lambda (y) x)) (lambda (z) z)) q)) 31 | '((closure y x ((x . (closure z z ())))))) 32 | 33 | (test "running backwards" 34 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 35 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 36 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 37 | (((lambda (x) (lambda (y) x)) 38 | ((lambda (_.0) _.0) (lambda (z) z))) 39 | (sym _.0)) 40 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 41 | (lambda (z) z)) 42 | (sym _.0)) 43 | (((lambda (_.0) _.0) 44 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 45 | (sym _.0)))) 46 | 47 | (test "fully-running-backwards" 48 | (run 5 (q) 49 | (fresh (e v) 50 | (evalo e v) 51 | (== `(,e ==> ,v) q))) 52 | '((((lambda (_.0) _.1) 53 | ==> (closure _.0 _.1 ())) (sym _.0)) 54 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 55 | ==> 56 | (closure _.1 _.2 ())) 57 | (sym _.0 _.1)) 58 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 59 | ==> 60 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1 _.3)) 63 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 64 | ==> 65 | (closure _.1 _.1 ())) 66 | (sym _.0 _.1)) 67 | ((((lambda (_.0) (_.0 _.0)) 68 | (lambda (_.1) (lambda (_.2) _.3))) 69 | ==> 70 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 71 | (=/= ((_.1 lambda))) 72 | (sym _.0 _.1 _.2)))) 73 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/hangout-7.scm: -------------------------------------------------------------------------------- 1 | (load "faster-miniKanren/mk-vicare.scm") 2 | (load "faster-miniKanren/mk.scm") 3 | 4 | ;; good ordering 5 | (define appendo 6 | (lambda (l s out) 7 | (conde 8 | [(== '() l) (== s out)] 9 | [(fresh (a d res) 10 | (== (cons a d) l) 11 | (== (cons a res) out) 12 | (appendo d s res))]))) 13 | 14 | #!eof 15 | 16 | ;; less good ordering (can cause infinite loops!) 17 | (define appendo 18 | (lambda (l s out) 19 | (conde 20 | [(== '() l) (== s out)] 21 | [(fresh (a d res) 22 | (appendo d s res) 23 | (== (cons a d) l) 24 | (== (cons a res) out))]))) 25 | 26 | (define append 27 | (lambda (l s) 28 | (cond 29 | [(null? l) s] 30 | [else (cons (car l) 31 | (append (cdr l) s))]))) 32 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/trans.scm: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.4.1 2 | Copyright 1984-2016 Cisco Systems, Inc. 3 | 4 | > (load "hangout-7.scm") 5 | > 5 6 | 5 7 | > (+ 3 4) 8 | 7 9 | > == 10 | # 11 | > 12 | 13 | Process scheme finished 14 | Chez Scheme Version 9.4.1 15 | Copyright 1984-2016 Cisco Systems, Inc. 16 | 17 | > == 18 | 19 | Exception: variable == is not bound 20 | Type (debug) to enter the debugger. 21 | > (load "hangout-7.scm") 22 | > == 23 | # 24 | > (= 5 5) 25 | #t 26 | > (= 5 6) 27 | #f 28 | > (equal? 5 5) 29 | #t 30 | > (equal? '(a b c) '(a b c)) 31 | #t 32 | > (equal? '(a ((b)) c) '(a ((b)) c)) 33 | #t 34 | > (equal? '(a ((b)) c) '(a ((e)) c)) 35 | #f 36 | > (== 6 6) 37 | # 38 | > == 39 | # 40 | > run 41 | 42 | Exception: invalid syntax run 43 | Type (debug) to enter the debugger. 44 | > (run 1 (q) (== 6 6)) 45 | (_.0) 46 | > (run 1 (q) (== 5 6)) 47 | () 48 | > (run 1 (q) (== q 6)) 49 | (6) 50 | > (run 1 (q) (== (list 3 4) (list 3 4))) 51 | (_.0) 52 | > (run 1 (q) (== '(3 4) (list 3 4))) 53 | (_.0) 54 | > (list 3 4) 55 | (3 4) 56 | > '(3 4) 57 | (3 4) 58 | > (equal? '(3 4) (list 3 4)) 59 | #t 60 | > (run 1 (q) (== (list 3 4) (list q 4))) 61 | (3) 62 | > (run 1 (x y) 63 | (== (list 3 y) 64 | (list x 4))) 65 | ((3 4)) 66 | > (run 1 (x y) 67 | (== (list 3 4) 68 | (list x y))) 69 | ((3 4)) 70 | > (run 1 (x y) 71 | (== (list x y) 72 | (list 3 4))) 73 | ((3 4)) 74 | > (run 1 (q) (== 5 6)) 75 | () 76 | > (run 1 (q) 77 | (== (list 3 4) 78 | (list q q))) 79 | () 80 | > (run 1 (q) 81 | (== (list 3 3) 82 | (list q q))) 83 | (3) 84 | > (run 1 (q) 85 | (== (list '(a b c) '(a b c)) 86 | (list q q))) 87 | ((a b c)) 88 | > (run 1 (q) 89 | (fresh () 90 | (== q 5))) 91 | (5) 92 | > (run 1 (q) 93 | (== q 5)) 94 | (5) 95 | > (run 1 (q) 96 | (fresh (x) 97 | (== x 5))) 98 | (_.0) 99 | > (run 1 (q) 100 | (fresh (x) 101 | (== x 5) 102 | (== q x))) 103 | (5) 104 | > (run 1 (q) 105 | (fresh (x) 106 | (== q x) 107 | (== x 5))) 108 | (5) 109 | > (run 1 (q) 110 | (fresh (x) 111 | (== q x))) 112 | (_.0) 113 | > (run 1 (x y) (== x y)) 114 | ((_.0 _.0)) 115 | > (run 1 (x y) (== 5 5)) 116 | ((_.0 _.1)) 117 | > (run 1 (x y) (== x y) (== x 5)) 118 | ((5 5)) 119 | > (run 1 (x y) (== x y) (== y 5)) 120 | ((5 5)) 121 | > (run 1 (x y) (== y 5) (== x y)) 122 | ((5 5)) 123 | > (run 1 (x y) 124 | (== x y) 125 | (== y 5) 126 | (== x 5)) 127 | ((5 5)) 128 | > (run 1 (x y) 129 | (== x y) 130 | (== y 5) 131 | (== x 6)) 132 | () 133 | > (run 1 (x y) 134 | (== y 5) 135 | (== x 6)) 136 | ((6 5)) 137 | > (run 1 (x y) 138 | (== x y) 139 | (== y 5) 140 | (== x 6)) 141 | () 142 | > (run 1 (x y) 143 | (== y 5) ; y == 5 144 | (== x 6) ; x == 6, y == 5 145 | (== x y)) 146 | () 147 | > (run 1 (x y) 148 | (fresh () 149 | (== x y) 150 | (== y 5) 151 | (== x 6))) 152 | () 153 | > (run 1 (x y) 154 | (fresh () 155 | (== y 5) 156 | (== x 6))) 157 | ((6 5)) 158 | > (run 1 (x y) 159 | (== y 5) 160 | (== x 6) 161 | (== x y)) 162 | () 163 | > (conde 164 | [(== x 5) (== y 7)] 165 | [(== x 6)]) 166 | # 167 | > (fresh (x) (== x 5)) 168 | # 169 | > (== x 5) 170 | 171 | Exception: variable x is not bound 172 | Type (debug) to enter the debugger. 173 | > (== 5 5) 174 | # 175 | > (run 1 (q) 176 | (conde 177 | [(== q 5)] 178 | [(== q 6)])) 179 | (5) 180 | > (run 1 (q) 181 | (== q 5)) 182 | (5) 183 | > (run 2 (q) 184 | (conde 185 | [(== q 5)] 186 | [(== q 6)])) 187 | (5 6) 188 | > (run 1 (q) 189 | (== q 6)) 190 | (6) 191 | > (run 2 (q) 192 | (conde 193 | [(== q 5)] 194 | [(== q 6)])) 195 | (5 6) 196 | > (run 2 (q) 197 | (conde 198 | [(== 7 5)] 199 | [(== q 6)])) 200 | (6) 201 | > (run 2 (q) 202 | (conde 203 | [(== 7 5)] 204 | [(== 4 6)])) 205 | () 206 | > (run 2 (q) 207 | (conde 208 | [(== 5 5)] 209 | [(== 4 6)])) 210 | (_.0) 211 | > (run 2 (q) 212 | (conde 213 | [(== 5 5)] 214 | [(== 4 4)])) 215 | (_.0 _.0) 216 | > (run 2 (q) 217 | (conde 218 | [(== 4 4)])) 219 | (_.0) 220 | > (run 2 (q) 221 | (conde 222 | [(== q 5)] 223 | [(== q 4)])) 224 | (5 4) 225 | > (run 1 (q) 226 | (conde 227 | [(== q 5)] 228 | [(== q 4)])) 229 | (5) 230 | > (run 3 (q) 231 | (conde 232 | [(== q 5)] 233 | [(== q 4)])) 234 | (5 4) 235 | > (run* (q) 236 | (conde 237 | [(== q 5)] 238 | [(== q 4)])) 239 | (5 4) 240 | > (run* (q) 241 | (conde 242 | [(== q 5)] 243 | [(== q 4)] 244 | [(== q 6)] 245 | [(== q 7)])) 246 | (5 4 6 7) 247 | > (run* (x y) 248 | (conde 249 | [(== x 5) (== y 1)] 250 | [(== x 4) (== y 2)] 251 | [(== x 6) (== y 3)] 252 | [(== x 7) (== y 4)])) 253 | ((5 1) (4 2) (6 3) (7 4)) 254 | > (run* (x y) 255 | (conde 256 | [(== x 5) (== y 1)] 257 | [(== x 4)] 258 | [(== y 3)] 259 | [(== x 7) (== y 4)])) 260 | ((5 1) (4 _.0) (_.0 3) (7 4)) 261 | > (run* (q) 262 | (fresh (x y) 263 | (fresh (z) 264 | (== z 5) 265 | (== y q)) 266 | (== y 6))) 267 | (6) 268 | > (run* (q) 269 | (fresh (x y) 270 | (fresh (z) 271 | (== x 5) 272 | (== y q)) 273 | (== z 6))) 274 | 275 | Exception: variable z is not bound 276 | Type (debug) to enter the debugger. 277 | > (run* (q) 278 | (fresh (x y) 279 | (fresh (q) 280 | (== q 7)) 281 | (== x 6))) 282 | (_.0) 283 | > (run* (q) 284 | (fresh (x y) 285 | (fresh (foo) 286 | (== foo 7)) 287 | (== x 6))) 288 | (_.0) 289 | > (run* (q) 290 | (fresh (x y) 291 | (fresh (foo) 292 | (conde 293 | [(fresh (z) 294 | (== q z)) 295 | (== 5 5)] 296 | [(conde 297 | [(== q 7)])])) 298 | (== x 6))) 299 | (_.0 7) 300 | > (run* (q) 301 | (fresh (x y) 302 | (fresh (foo) 303 | (conde 304 | [(fresh (z) 305 | (== q z)) 306 | (== 5 5)] 307 | [(conde 308 | [(== q 7)])])) 309 | (== (== x 6) y))) 310 | (_.0 7) 311 | > (run* (q) 312 | (fresh (x y) 313 | (fresh (foo) 314 | (conde 315 | [(fresh (z) 316 | (== q z)) 317 | (== 5 5)] 318 | [(conde 319 | [(== q 7)])])) 320 | (== (== x 6) y))) 321 | (_.0 7) 322 | > (run 1 (q) 323 | (fresh (x) 324 | (== x 5))) 325 | (_.0) 326 | > (run 1 (q) 327 | (fresh (x) 328 | (== x 5) 329 | (== x q))) 330 | (5) 331 | > (run 1 (q) 332 | (fresh (x) 333 | (== (== x 5) q))) 334 | (#) 335 | > (run 1 (q) (== q 5)) 336 | (5) 337 | > (run 1 (q) (== q '(a b c))) 338 | ((a b c)) 339 | > (run 1 (q) (== '(a b c) q)) 340 | ((a b c)) 341 | > (run 1 (q) (== q '(a b c))) 342 | ((a b c)) 343 | > (run 1 (q) (== q '(a b c)) (== q 5)) 344 | () 345 | > (run 1 (q) 346 | (conde 347 | [(== q '(a b c))] 348 | [(== q 5)])) 349 | ((a b c)) 350 | > (run 2 (q) 351 | (conde 352 | [(== q '(a b c))] 353 | [(== q 5)])) 354 | ((a b c) 5) 355 | > (run 1 (q) (== q '(a b c))) 356 | ((a b c)) 357 | > (run 1 (q) (== (list q) q)) 358 | () 359 | > ==, fresh, conde run, run* -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-7/trans2.scm: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.4.1 2 | Copyright 1984-2016 Cisco Systems, Inc. 3 | 4 | > (append '(a b c) '(d e)) 5 | (a b c d e) ; out 6 | > (load "hangout-7.scm") 7 | > (run 1 (a d) 8 | (fresh (l) 9 | (== '(1 2 3) l) 10 | (== (cons a d) l))) 11 | ((1 (2 3))) 12 | > (run 1 (a d) 13 | (fresh (l) 14 | (== (cons a d) l))) 15 | ((_.0 _.1)) 16 | > (run 1 (a d l) 17 | (== (cons a d) l)) 18 | ((_.0 _.1 (_.0 . _.1))) 19 | > (run 1 (q) 20 | (fresh (l) 21 | (== (car l) q))) 22 | 23 | Exception in car: #((unbound) (scope) 13) is not a pair 24 | Type (debug) to enter the debugger. 25 | > (run 1 (q) 26 | (fresh (l) 27 | (== (cons l l) q))) 28 | ((_.0 . _.0)) 29 | > (run 1 (a d) 30 | (fresh (l) 31 | (== '(1 2 3) l) 32 | (== (cons a d) l))) 33 | ((1 (2 3))) 34 | > (run 1 (a d) 35 | (fresh (l) 36 | (== '(1 2 3) l) 37 | (== `(,a . ,d) l))) 38 | ((1 (2 3))) 39 | > 40 | 41 | Process scheme finished 42 | Chez Scheme Version 9.4.1 43 | Copyright 1984-2016 Cisco Systems, Inc. 44 | 45 | > (load "hangout-y.scm") 46 | 47 | Exception in load: failed for hangout-y.scm: no such file or directory 48 | Type (debug) to enter the debugger. 49 | > (load "hangout-7.scm") 50 | > (run 1 (q) 51 | (appendo '(a b c) '(d e) q)) 52 | ((a b c d e)) 53 | > (append '(a b c) '(d e)) 54 | (a b c d e) 55 | > (run 2 (q) 56 | (appendo '(a b c) '(d e) q)) 57 | ((a b c d e)) 58 | > (run* (q) 59 | (appendo '(a b c) '(d e) q)) 60 | ((a b c d e)) 61 | > (run* (q) 62 | (appendo '(a b c) '(d e) '(a b c d e))) 63 | (_.0) 64 | > (run* (q) 65 | (appendo '(a b c) '(d e) '(a b c f e))) 66 | () 67 | > (run* (q) 68 | (appendo '(a b c) q '(a b c d e))) 69 | ((d e)) 70 | > (run* (q) 71 | (appendo q '(d e) '(a b c d e))) 72 | ((a b c)) 73 | > (run 1 (x y) 74 | (appendo x y '(a b c d e))) 75 | ((() (a b c d e))) 76 | > (run 2 (x y) 77 | (appendo x y '(a b c d e))) 78 | ((() (a b c d e)) 79 | ((a) (b c d e))) 80 | > (run 6 (x y) 81 | (appendo x y '(a b c d e))) 82 | ((() (a b c d e)) 83 | ((a) (b c d e)) 84 | ((a b) (c d e)) 85 | ((a b c) (d e)) 86 | ((a b c d) (e)) 87 | ((a b c d e) ())) 88 | > (run 7 (x y) 89 | (appendo x y '(a b c d e))) 90 | ((() (a b c d e)) ((a) (b c d e)) ((a b) (c d e)) 91 | ((a b c) (d e)) ((a b c d) (e)) ((a b c d e) ())) 92 | > (length (run 7 (x y) 93 | (appendo x y '(a b c d e)))) 94 | 6 95 | > (length (run 7 (x y) 96 | (appendo x y '(a b c d e)))) 97 | 6 98 | > (run* (x y) 99 | (appendo x y '(a b c d e))) 100 | ((() (a b c d e)) 101 | ((a) (b c d e)) 102 | ((a b) (c d e)) 103 | ((a b c) (d e)) 104 | ((a b c d) (e)) 105 | ((a b c d e) ())) 106 | > (run* (x y) 107 | (appendo x y '(a b c))) 108 | ((() (a b c)) 109 | ((a) (b c)) 110 | ((a b) (c)) 111 | ((a b c) ())) 112 | > (run* (x y z) 113 | (appendo x y z)) 114 | C-c C-c 115 | break> r 116 | > (run 1 (x y z) 117 | (appendo x y z)) 118 | ((() _.0 _.0)) 119 | > (append '() 5) 120 | 5 121 | > (run 2 (x y z) 122 | (appendo x y z)) 123 | ((() _.0 _.0) 124 | ((_.0) _.1 (_.0 . _.1))) 125 | > (append '(foo) 'bar) 126 | (foo . bar) 127 | > (run 3 (x y z) 128 | (appendo x y z)) 129 | ((() _.0 _.0) 130 | ((_.0) _.1 (_.0 . _.1)) 131 | ((_.0 _.1) _.2 (_.0 _.1 . _.2))) 132 | > (run* (q) 133 | (appendo '(a b c) `(d ,q) '(a b c d e))) 134 | (e) 135 | > (run* (q) 136 | (appendo '(a b c) `(d . ,q) '(a b c d e))) 137 | ((e)) 138 | > (run* (q) 139 | (appendo '(a b) `(c . ,q) '(a b c d e))) 140 | ((d e)) 141 | > (run* (x y) 142 | (appendo '(a . ,x) `(c . ,y) '(a b c d e))) 143 | () 144 | > (run* (x y) 145 | (appendo `(a . ,x) `(c . ,y) '(a b c d e))) 146 | (((b) (d e))) 147 | > (run* (x y z) 148 | (appendo `(a . ,x) `(c . ,y) `(,z b c d e))) 149 | (((b) (d e) a)) 150 | > 151 | 152 | Process scheme finished 153 | Chez Scheme Version 9.4.1 154 | Copyright 1984-2016 Cisco Systems, Inc. 155 | 156 | > (load "hangout-7.scm") 157 | > (run 6 (x y) 158 | (appendo x y '(a b c d e))) 159 | ((() (a b c d e)) 160 | ((a) (b c d e)) 161 | ((a b) (c d e)) 162 | ((a b c) (d e)) 163 | ((a b c d) (e)) 164 | ((a b c d e) ())) 165 | > (run 7 (x y) 166 | (appendo x y '(a b c d e))) 167 | C-c C-c 168 | break> r 169 | > (define appendo 170 | (lambda (l s out) 171 | (conde 172 | [(== '() l) (== s out)] 173 | [(fresh (a d res) 174 | (== (cons a d) l) 175 | (== (cons a res) out) 176 | (appendo d s res))]))) 177 | 178 | > (run 7 (x y) 179 | (appendo x y '(a b c d e))) 180 | ((() (a b c d e)) 181 | ((a) (b c d e)) 182 | ((a b) (c d e)) 183 | ((a b c) (d e)) 184 | ((a b c d) (e)) 185 | ((a b c d e) ())) 186 | > -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-8/hangout-8.scm: -------------------------------------------------------------------------------- 1 | (load "faster-miniKanren/mk-vicare.scm") 2 | (load "faster-miniKanren/mk.scm") 3 | 4 | 5 | 6 | 7 | 8 | 9 | ;; Scheme/functional world 10 | ;; car & cdr & returning values 11 | (define member? 12 | (lambda (x l) 13 | (cond 14 | [(null? l) #f] 15 | [(equal? (car l) x) #t] 16 | [else (member? x (cdr l))]))) 17 | 18 | (define membero 19 | (lambda (x l) 20 | (conde 21 | [(fresh (a d) 22 | (== (cons a d) l) 23 | (== a x))] 24 | [(fresh (a d) 25 | (== (cons a d) l) 26 | (=/= a x) 27 | (membero x d))]))) 28 | 29 | (define membero 30 | (lambda (x l) 31 | (fresh (a d) 32 | (== (cons a d) l) 33 | (conde 34 | [(== a x)] 35 | [(=/= a x) (membero x d)])))) 36 | 37 | (define member? 38 | (lambda (x l) 39 | (cond 40 | [(null? l) #f] 41 | [(and (not (null? l)) 42 | (equal? (car l) x)) 43 | #t] 44 | [(and (not (null? l)) 45 | (not (equal? (car l) x))) 46 | (member? x (cdr l))]))) 47 | 48 | 49 | 50 | ;; miniKanren/relational world 51 | ;; == & cons & associating values with 'out' 52 | (define membero 53 | (lambda (x l x-in-l) 54 | (conde 55 | [(== '() l) (== #f x-in-l)] 56 | [(fresh (a d) ; first thing in l is a 57 | (== (cons a d) l) 58 | (== a x) 59 | (== #t x-in-l))] 60 | [(fresh (a d) ; first thing in l isn't a 61 | (== (cons a d) l) 62 | (=/= a x) ;; disequality constraint 63 | (membero x d x-in-l))]))) 64 | 65 | (define membero 66 | (lambda (x l x-in-l) 67 | (conde 68 | [(fresh (a d) ; first thing in l isn't a 69 | (== (cons a d) l) 70 | (=/= a x) ;; disequality constraint 71 | (membero x d x-in-l))] 72 | [(fresh (a d) ; first thing in l is a 73 | (== (cons a d) l) 74 | (== a x) 75 | (== #t x-in-l))] 76 | [(== '() l) (== #f x-in-l)]))) 77 | 78 | 79 | 80 | 81 | #!eof 82 | 83 | car caro 84 | cdr cdro 85 | cons conso 86 | 87 | ;; l = (1 2 3 4) 88 | (lambda (l) 89 | (fresh (a d) 90 | (== (cons a d) l))) 91 | 92 | (== `(,a . ,d) ;; a = 1 93 | `(1 . (2 3 4))) ;; d = (2 3 4) 94 | 95 | (car '(1 2 3 4 5)) => 1 96 | (caro '(1 2 3 4 5) out) => out = 1 97 | (caro '(1 2 3 4 5) 1) => succeed 98 | (caro '(1 2 3 4 5) 2) => fail 99 | (caro l 2) => l = (2 . d) 100 | 101 | (define caro 102 | (lambda (l out) 103 | (fresh (a d) 104 | (== (cons a d) l) 105 | (== a out)))) 106 | 107 | (define caro 108 | (lambda (l a) 109 | (fresh (_) 110 | (== (cons a _) l)))) 111 | 112 | (define cdro 113 | (lambda (l d) 114 | (fresh (_) 115 | (== (cons _ d) l)))) 116 | 117 | (cons 5 '(6 7)) => (5 6 7) 118 | 119 | (define conso 120 | (lambda (a d out) 121 | (== (cons a d) out))) 122 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/==-tests.scm: -------------------------------------------------------------------------------- 1 | (test "1" 2 | (run 1 (q) (== 5 q)) 3 | '(5)) 4 | 5 | (test "2" 6 | (run* (q) 7 | (conde 8 | [(== 5 q)] 9 | [(== 6 q)])) 10 | '(5 6)) 11 | 12 | (test "3" 13 | (run* (q) 14 | (fresh (a d) 15 | (conde 16 | [(== 5 a)] 17 | [(== 6 d)]) 18 | (== `(,a . ,d) q))) 19 | '((5 . _.0) (_.0 . 6))) 20 | 21 | (define appendo 22 | (lambda (l s out) 23 | (conde 24 | [(== '() l) (== s out)] 25 | [(fresh (a d res) 26 | (== `(,a . ,d) l) 27 | (== `(,a . ,res) out) 28 | (appendo d s res))]))) 29 | 30 | (test "4" 31 | (run* (q) (appendo '(a b c) '(d e) q)) 32 | '((a b c d e))) 33 | 34 | (test "5" 35 | (run* (q) (appendo q '(d e) '(a b c d e))) 36 | '((a b c))) 37 | 38 | (test "6" 39 | (run* (q) (appendo '(a b c) q '(a b c d e))) 40 | '((d e))) 41 | 42 | (test "7" 43 | (run 5 (q) 44 | (fresh (l s out) 45 | (appendo l s out) 46 | (== `(,l ,s ,out) q))) 47 | '((() _.0 _.0) 48 | ((_.0) _.1 (_.0 . _.1)) 49 | ((_.0 _.1) _.2 (_.0 _.1 . _.2)) 50 | ((_.0 _.1 _.2) _.3 (_.0 _.1 _.2 . _.3)) 51 | ((_.0 _.1 _.2 _.3) _.4 (_.0 _.1 _.2 _.3 . _.4)))) 52 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 William E. Byrd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/README.md: -------------------------------------------------------------------------------- 1 | # miniKanren-with-symbolic-constraints 2 | 3 | A revision of https://github.com/webyrd/miniKanren-with-symbolic-constraints/ for better performance. Up to 10x faster for large queries involving heavy use of constraints. 4 | 5 | Includes `==`, `=/=`, `symbolo`, and `numbero`. `absento` is included, but the argument is required to be an eqv-comparable ground atom. 6 | 7 | Eigen was removed. 8 | 9 | ## Running 10 | 11 | ### Racket 12 | 13 | ``` 14 | (require "mk.rkt") 15 | ``` 16 | 17 | ### Vicare 18 | 19 | ``` 20 | (load "mk-vicare.scm") 21 | (load "mk.scm") 22 | ``` 23 | 24 | ## Running Tests 25 | 26 | After loading miniKanren as above, 27 | 28 | ``` 29 | (load "test-all.scm") 30 | ``` 31 | 32 | regardless of scheme implementation. 33 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/absento-closure-tests.scm: -------------------------------------------------------------------------------- 1 | (test "absento 'closure-1a" 2 | (run* (q) (absento 'closure q) (== q 'closure)) 3 | '()) 4 | 5 | (test "absento 'closure-1b" 6 | (run* (q) (== q 'closure) (absento 'closure q)) 7 | '()) 8 | 9 | (test "absento 'closure-2a" 10 | (run* (q) (fresh (a d) (== q 'closure) (absento 'closure q))) 11 | '()) 12 | 13 | (test "absento 'closure-2b" 14 | (run* (q) (fresh (a d) (absento 'closure q) (== q 'closure))) 15 | '()) 16 | 17 | (test "absento 'closure-3a" 18 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q))) 19 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 20 | 21 | (test "absento 'closure-3b" 22 | (run* (q) (fresh (a d) (== `(,a . ,d) q) (absento 'closure q))) 23 | '(((_.0 . _.1) (absento (closure _.0) (closure _.1))))) 24 | 25 | (test "absento 'closure-4a" 26 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure a))) 27 | '()) 28 | 29 | (test "absento 'closure-4b" 30 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure a) (== `(,a . ,d) q))) 31 | '()) 32 | 33 | (test "absento 'closure-4c" 34 | (run* (q) (fresh (a d) (== 'closure a) (absento 'closure q) (== `(,a . ,d) q))) 35 | '()) 36 | 37 | (test "absento 'closure-4d" 38 | (run* (q) (fresh (a d) (== 'closure a) (== `(,a . ,d) q) (absento 'closure q))) 39 | '()) 40 | 41 | (test "absento 'closure-5a" 42 | (run* (q) (fresh (a d) (absento 'closure q) (== `(,a . ,d) q) (== 'closure d))) 43 | '()) 44 | 45 | (test "absento 'closure-5b" 46 | (run* (q) (fresh (a d) (absento 'closure q) (== 'closure d) (== `(,a . ,d) q))) 47 | '()) 48 | 49 | (test "absento 'closure-5c" 50 | (run* (q) (fresh (a d) (== 'closure d) (absento 'closure q) (== `(,a . ,d) q))) 51 | '()) 52 | 53 | (test "absento 'closure-5d" 54 | (run* (q) (fresh (a d) (== 'closure d) (== `(,a . ,d) q) (absento 'closure q))) 55 | '()) 56 | 57 | (test "absento 'closure-6" 58 | (run* (q) 59 | (== `(3 (closure x (x x) ((y . 7))) #t) q) 60 | (absento 'closure q)) 61 | '()) 62 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/eval.scm: -------------------------------------------------------------------------------- 1 | (load "mk-vicare.scm") 2 | (load "mk.scm") 3 | (load "numbers.scm") 4 | 5 | (define lookupo 6 | (lambda (x env val) 7 | (fresh (y v env^) 8 | (== `((,y . ,v) . ,env^) env) 9 | (symbolo y) 10 | (conde 11 | [(== x y) (== val v)] 12 | [(=/= x y) 13 | (lookupo x env^ val)])))) 14 | 15 | (define evalo 16 | (lambda (expr env value) 17 | (conde 18 | [(fresh (c) 19 | (== `(const ,c) expr) 20 | (== value c) 21 | (absento 'closure c))] 22 | [(symbolo expr) ; variable 23 | (lookupo expr env value)] 24 | [(fresh (x body) 25 | (== `(lambda (,x) ,body) expr) 26 | (symbolo x) 27 | (== `(closure ,x ,body ,env) value))] 28 | [(fresh (e1 e2 x body env^ arg) 29 | (== `(apply ,e1 ,e2) expr) 30 | (evalo e1 env `(closure ,x ,body ,env^)) 31 | (evalo e2 env arg) 32 | (evalo body `((,x . ,arg) . ,env^) value))] 33 | [(fresh (e1 e2 n1 n2) 34 | (== `(+ ,e1 ,e2) expr) 35 | (evalo e1 env n1) 36 | (evalo e2 env n2) 37 | (pluso n1 n2 value))] 38 | [(fresh (e1 e2 n1 n2) 39 | (== `(* ,e1 ,e2) expr) 40 | (evalo e1 env n1) 41 | (evalo e2 env n2) 42 | (*o n1 n2 value))]))) 43 | 44 | (run* (q) 45 | (evalo `(+ (const ,(build-num 1)) 46 | (const ,(build-num 2))) 47 | '() 48 | q)) 49 | 50 | (run 10 (expr) 51 | (evalo expr 52 | '() 53 | (build-num 3))) 54 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/matche.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "mk.rkt") 3 | (require (for-syntax racket/syntax)) 4 | 5 | (provide matche lambdae defmatche) 6 | 7 | (define-for-syntax memp memf) 8 | 9 | (include "matche.scm") 10 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/matche.scm: -------------------------------------------------------------------------------- 1 | ; new version of matche 2 | ; fixes depth related issues, and works with dots 3 | ; 4 | ; https://github.com/calvis/cKanren/blob/dev/cKanren/matche.rkt#L54 5 | 6 | ; Note that this definition is available at syntax phase in chez and vicare due to implicit 7 | ; phasing, but not in Racket (which uses explicit phasing). Racket already has a version available 8 | ; by default though, so that's fine. This definition isn't just isn't used in Racket. 9 | (define syntax->list 10 | (lambda (e) 11 | (syntax-case e () 12 | [() '()] 13 | [(x . r) (cons #'x (syntax->list #'r))]))) 14 | 15 | (define-syntax defmatche 16 | (lambda (stx) 17 | (syntax-case stx () 18 | [(defmatche (name args ...) clause ...) 19 | #'(define (name args ...) 20 | (matche (args ...) clause ...))]))) 21 | 22 | (define-syntax lambdae 23 | (syntax-rules () 24 | ((_ (x ...) c c* ...) 25 | (lambda (x ...) (matche (x ...) c c* ...))))) 26 | 27 | (define-syntax matche 28 | (lambda (stx) 29 | (syntax-case stx () 30 | [(matche (v ...) ([pat ...] g ...) ...) 31 | (let () 32 | (define remove-duplicates 33 | (lambda (ls eq-pred) 34 | (cond 35 | [(null? ls) '()] 36 | [(memp (lambda (x) (eq-pred (car ls) x)) (cdr ls)) 37 | (remove-duplicates (cdr ls) eq-pred)] 38 | [else (cons (car ls) (remove-duplicates (cdr ls) eq-pred))]))) 39 | (define parse-pattern 40 | (lambda (args pat) 41 | (syntax-case #`(#,args #,pat) () 42 | [(() ()) #'(() () ())] 43 | [((a args ...) [p pat ...]) 44 | (with-syntax ([(p^ (c ...) (x ...)) 45 | (parse-patterns-for-arg #'a #'p)]) 46 | (with-syntax ([([pat^ ...] (c^ ...) (x^ ...)) 47 | (parse-pattern #'(args ...) #'[pat ...])]) 48 | #'([p^ pat^ ...] (c ... c^ ...) (x ... x^ ...))))] 49 | [x (error 'parse-pattern "bad syntax ~s ~s" args pat)]))) 50 | (define parse-patterns-for-arg 51 | (lambda (v pat) 52 | (define loop 53 | (lambda (pat) 54 | (syntax-case pat (unquote ?? ?) ; ?? is the new _, since _ isn't legal in R6 55 | [(unquote ??) 56 | (with-syntax ([_new (generate-temporary #'?_)]) 57 | #'((unquote _new) () (_new)))] 58 | [(unquote x) 59 | (when (free-identifier=? #'x v) 60 | (error 'matche "argument ~s appears in pattern at an invalid depth" 61 | (syntax->datum #'x))) 62 | #'((unquote x) () (x))] 63 | [(unquote (? c x)) 64 | (when (free-identifier=? #'x v) 65 | (error 'matche "argument ~s appears in pattern at an invalid depth" 66 | (syntax->datum #'x))) 67 | #'((unquote x) ((c x)) (x))] 68 | [(a . d) 69 | (with-syntax ([((pat1 (c1 ...) (x1 ...)) 70 | (pat2 (c2 ...) (x2 ...))) 71 | (map loop (syntax->list #'(a d)))]) 72 | #'((pat1 . pat2) (c1 ... c2 ...) (x1 ... x2 ...)))] 73 | [x #'(x () ())]))) 74 | (syntax-case pat (unquote ?) 75 | [(unquote u) 76 | (cond 77 | [(and (identifier? #'u) 78 | (free-identifier=? v #'u)) 79 | #'((unquote u) () ())] 80 | [else (loop pat)])] 81 | [(unquote (? c u)) 82 | (cond 83 | [(and (identifier? #'u) 84 | (free-identifier=? v #'u)) 85 | #'((unquote u) ((c x)) ())] 86 | [else (loop pat)])] 87 | [else (loop pat)]))) 88 | (unless 89 | (andmap (lambda (y) (= (length (syntax->datum #'(v ...))) (length y))) 90 | (syntax->datum #'([pat ...] ...))) 91 | (error 'matche "pattern wrong length blah")) 92 | (with-syntax ([(([pat^ ...] (c ...) (x ...)) ...) 93 | (map (lambda (y) (parse-pattern #'(v ...) y)) 94 | (syntax->list #'([pat ...] ...)))]) 95 | (with-syntax ([((x^ ...) ...) 96 | (map (lambda (ls) 97 | (remove-duplicates (syntax->list ls) free-identifier=?)) 98 | (syntax->list #'((x ...) ...)))]) 99 | (with-syntax ([body 100 | #'(conde 101 | [(fresh (x^ ...) c ... (== `[pat^ ...] ls) g ...)] 102 | ...)]) 103 | #'(let ([ls (list v ...)]) body)))))] 104 | [(matche v (pat g ...) ...) 105 | #'(matche (v) ([pat] g ...) ...)]))) 106 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/mk-vicare.scm: -------------------------------------------------------------------------------- 1 | ; This file needs to be loaded before mk.scm for Vicare. I can't figure 2 | ; out how to do loads relative to a source file rather than the working 3 | ; directory, else this file would load mk.scm. 4 | 5 | 6 | ; Trie implementation, due to Abdulaziz Ghuloum. Used for substitution 7 | ; and constraint store. 8 | 9 | ;;; subst ::= (empty) 10 | ;;; | (node even odd) 11 | ;;; | (data idx val) 12 | 13 | (define-record-type node (fields e o)) 14 | 15 | (define-record-type data (fields idx val)) 16 | 17 | (define shift (lambda (n) (fxsra n 1))) 18 | 19 | (define unshift (lambda (n i) (fx+ (fxsll n 1) i))) 20 | 21 | ;;; interface 22 | 23 | (define t:size 24 | (lambda (x) (t:aux:size x))) 25 | 26 | (define t:bind 27 | (lambda (xi v s) 28 | (unless (and (fixnum? xi) (>= xi 0)) 29 | (error 't:bind "index must be a fixnum, got ~s" xi)) 30 | (t:aux:bind xi v s))) 31 | 32 | (define t:unbind 33 | (lambda (xi s) 34 | (unless (and (fixnum? xi) (>= xi 0)) 35 | (error 't:unbind "index must be a fixnum, got ~s" xi)) 36 | (t:aux:unbind xi s))) 37 | 38 | (define t:lookup 39 | (lambda (xi s) 40 | (unless (and (fixnum? xi) (>= xi 0)) 41 | (error 't:lookup "index must be a fixnum, got ~s" xi)) 42 | (t:aux:lookup xi s))) 43 | 44 | (define t:binding-value 45 | (lambda (s) 46 | (unless (data? s) 47 | (error 't:binding-value "not a binding ~s" s)) 48 | (data-val s))) 49 | 50 | ;;; helpers 51 | 52 | (define t:aux:push 53 | (lambda (xi vi xj vj) 54 | (if (fxeven? xi) 55 | (if (fxeven? xj) 56 | (make-node (t:aux:push (shift xi) vi (shift xj) vj) '()) 57 | (make-node (make-data (shift xi) vi) (make-data (shift xj) vj))) 58 | (if (fxeven? xj) 59 | (make-node (make-data (shift xj) vj) (make-data (shift xi) vi)) 60 | (make-node '() (t:aux:push (shift xi) vi (shift xj) vj)))))) 61 | 62 | (define t:aux:bind 63 | (lambda (xi vi s*) 64 | (cond 65 | [(node? s*) 66 | (if (fxeven? xi) 67 | (make-node (t:aux:bind (shift xi) vi (node-e s*)) (node-o s*)) 68 | (make-node (node-e s*) (t:aux:bind (shift xi) vi (node-o s*))))] 69 | [(data? s*) 70 | (let ([xj (data-idx s*)] [vj (data-val s*)]) 71 | (if (fx= xi xj) 72 | (make-data xi vi) 73 | (t:aux:push xi vi xj vj)))] 74 | [else (make-data xi vi)]))) 75 | 76 | (define t:aux:lookup 77 | (lambda (xi s*) 78 | (cond 79 | [(node? s*) 80 | (if (fxeven? xi) 81 | (t:aux:lookup (shift xi) (node-e s*)) 82 | (t:aux:lookup (shift xi) (node-o s*)))] 83 | [(data? s*) 84 | (if (fx= (data-idx s*) xi) 85 | s* 86 | #f)] 87 | [else #f]))) 88 | 89 | (define t:aux:size 90 | (lambda (s*) 91 | (cond 92 | [(node? s*) (fx+ (t:aux:size (node-e s*)) (t:aux:size (node-o s*)))] 93 | [(data? s*) 1] 94 | [else 0]))) 95 | 96 | (define t:aux:cons^ 97 | (lambda (e o) 98 | (cond 99 | [(or (node? e) (node? o)) (make-node e o)] 100 | [(data? e) 101 | (make-data (unshift (data-idx e) 0) (data-val e))] 102 | [(data? o) 103 | (make-data (unshift (data-idx o) 1) (data-val o))] 104 | [else '()]))) 105 | 106 | (define t:aux:unbind 107 | (lambda (xi s*) 108 | (cond 109 | [(node? s*) 110 | (if (fxeven? xi) 111 | (t:aux:cons^ (t:aux:unbind (shift xi) (node-e s*)) (node-o s*)) 112 | (t:aux:cons^ (node-e s*) (t:aux:unbind (shift xi) (node-o s*))))] 113 | [(and (data? s*) (fx= (data-idx s*) xi)) '()] 114 | [else s*]))) 115 | 116 | 117 | ; Substitution representation 118 | 119 | (define empty-subst-map '()) 120 | 121 | (define subst-map-length t:size) 122 | 123 | ; Returns #f if not found, or a pair of u and the result of the lookup. 124 | ; This distinguishes between #f indicating absence and being the result. 125 | (define subst-map-lookup 126 | (lambda (u S) 127 | (let ((res (t:lookup (var-idx u) S))) 128 | (if res 129 | (data-val res) 130 | unbound)))) 131 | 132 | (define (subst-map-add S var val) 133 | (t:bind (var-idx var) val S)) 134 | 135 | (define subst-map-eq? eq?) 136 | 137 | 138 | ; Alternative (unused) substitution representation, using alists. 139 | ; Performance with the tries is usually about the same and 140 | ; can be much better for huge substitutions. 141 | 142 | #| 143 | (define empty-subst-map '()) 144 | 145 | (define subst-map-length length) 146 | 147 | ; Returns #f if not found, or a pair of u and the result of the lookup. 148 | ; This distinguishes between #f indicating absence and being the result. 149 | (define subst-map-lookup 150 | (lambda (u S) 151 | (let ((res (assq u S))) 152 | (if res 153 | (cdr res) 154 | unbound)))) 155 | 156 | (define (subst-map-add S var val) 157 | (cons (cons var val) S)) 158 | 159 | (define subst-map-eq? eq?) 160 | |# 161 | 162 | 163 | ; Constraint store representation 164 | 165 | (define empty-C '()) 166 | 167 | (define set-c 168 | (lambda (v c st) 169 | (state (state-S st) (t:bind (var-idx v) c (state-C st))))) 170 | 171 | (define lookup-c 172 | (lambda (v st) 173 | (let ((res (t:lookup (var-idx v) (state-C st)))) 174 | (if res 175 | (data-val res) 176 | empty-c)))) 177 | 178 | ; t:unbind either is buggy or doesn't do what I would expect, so 179 | ; I implement remove by setting the value to the empty constraint record. 180 | (define remove-c 181 | (lambda (v st) 182 | (let ((res (t:bind (var-idx v) empty-c (state-C st)))) 183 | (state (state-S st) res)))) 184 | 185 | 186 | ; Misc. missing functions 187 | 188 | (define (remove-duplicates l) 189 | (cond ((null? l) 190 | '()) 191 | ((member (car l) (cdr l)) 192 | (remove-duplicates (cdr l))) 193 | (else 194 | (cons (car l) (remove-duplicates (cdr l)))))) 195 | 196 | (define (foldl f init seq) 197 | (if (null? seq) 198 | init 199 | (foldl f 200 | (f (car seq) init) 201 | (cdr seq)))) 202 | 203 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide run run* 4 | == =/= 5 | fresh 6 | conde 7 | symbolo numbero 8 | absento 9 | (all-defined-out)) 10 | 11 | ;; extra stuff for racket 12 | ;; due mostly to samth 13 | (define (list-sort f l) (sort l f)) 14 | 15 | (define (remp f l) (filter-not f l)) 16 | 17 | (define (call-with-string-output-port f) 18 | (define p (open-output-string)) 19 | (f p) 20 | (get-output-string p)) 21 | 22 | (define (exists f l) (ormap f l)) 23 | 24 | (define for-all andmap) 25 | 26 | (define (find f l) 27 | (cond [(memf f l) => car] [else #f])) 28 | 29 | (define memp memf) 30 | 31 | (define (var*? v) (var? (car v))) 32 | 33 | 34 | ; Substitution representation 35 | 36 | (define empty-subst-map (hasheq)) 37 | 38 | (define subst-map-length hash-count) 39 | 40 | ; Returns #f if not found, or a pair of u and the result of the lookup. 41 | ; This distinguishes between #f indicating absence and being the result. 42 | (define subst-map-lookup 43 | (lambda (u S) 44 | (hash-ref S u unbound))) 45 | 46 | (define (subst-map-add S var val) 47 | (hash-set S var val)) 48 | 49 | (define subst-map-eq? eq?) 50 | 51 | 52 | ; Constraint store representation 53 | 54 | (define empty-C (hasheq)) 55 | 56 | (define set-c 57 | (lambda (v c st) 58 | (state (state-S st) (hash-set (state-C st) v c)))) 59 | 60 | (define lookup-c 61 | (lambda (v st) 62 | (hash-ref (state-C st) v empty-c))) 63 | 64 | (define remove-c 65 | (lambda (v st) 66 | (state (state-S st) (hash-remove (state-C st) v)))) 67 | 68 | 69 | (include "mk.scm") 70 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "numbero-1" 2 | (run* (q) (numbero q)) 3 | '((_.0 (num _.0)))) 4 | 5 | (test "numbero-2" 6 | (run* (q) (numbero q) (== 5 q)) 7 | '(5)) 8 | 9 | (test "numbero-3" 10 | (run* (q) (== 5 q) (numbero q)) 11 | '(5)) 12 | 13 | (test "numbero-4" 14 | (run* (q) (== 'x q) (numbero q)) 15 | '()) 16 | 17 | (test "numbero-5" 18 | (run* (q) (numbero q) (== 'x q)) 19 | '()) 20 | 21 | (test "numbero-6" 22 | (run* (q) (numbero q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "numbero-7" 26 | (run* (q) (== `(1 . 2) q) (numbero q)) 27 | '()) 28 | 29 | (test "numbero-8" 30 | (run* (q) (fresh (x) (numbero x))) 31 | '(_.0)) 32 | 33 | (test "numbero-9" 34 | (run* (q) (fresh (x) (numbero x))) 35 | '(_.0)) 36 | 37 | (test "numbero-10" 38 | (run* (q) (fresh (x) (numbero x) (== x q))) 39 | '((_.0 (num _.0)))) 40 | 41 | (test "numbero-11" 42 | (run* (q) (fresh (x) (numbero q) (== x q) (numbero x))) 43 | '((_.0 (num _.0)))) 44 | 45 | (test "numbero-12" 46 | (run* (q) (fresh (x) (numbero q) (numbero x) (== x q))) 47 | '((_.0 (num _.0)))) 48 | 49 | (test "numbero-13" 50 | (run* (q) (fresh (x) (== x q) (numbero q) (numbero x))) 51 | '((_.0 (num _.0)))) 52 | 53 | (test "numbero-14-a" 54 | (run* (q) (fresh (x) (numbero q) (== 5 x))) 55 | '((_.0 (num _.0)))) 56 | 57 | (test "numbero-14-b" 58 | (run* (q) (fresh (x) (numbero q) (== 5 x) (== x q))) 59 | '(5)) 60 | 61 | (test "numbero-15" 62 | (run* (q) (fresh (x) (== q x) (numbero q) (== 'y x))) 63 | '()) 64 | 65 | (test "numbero-16-a" 66 | (run* (q) (numbero q) (=/= 'y q)) 67 | '((_.0 (num _.0)))) 68 | 69 | (test "numbero-16-b" 70 | (run* (q) (=/= 'y q) (numbero q)) 71 | '((_.0 (num _.0)))) 72 | 73 | (test "numbero-17" 74 | (run* (q) (numbero q) (=/= `(1 . 2) q)) 75 | '((_.0 (num _.0)))) 76 | 77 | (test "numbero-18" 78 | (run* (q) (numbero q) (=/= 5 q)) 79 | '((_.0 (=/= ((_.0 5))) (num _.0)))) 80 | 81 | (test "numbero-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (numbero x) 85 | (numbero y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (num _.0 _.1)))) 88 | 89 | (test "numbero-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (numbero x) 94 | (numbero y))) 95 | '(((_.0 _.1) (num _.0 _.1)))) 96 | 97 | (test "numbero-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (numbero x) 102 | (numbero x))) 103 | '(((_.0 _.1) (num _.0)))) 104 | 105 | (test "numbero-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (numbero x) 109 | (numbero x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (num _.0)))) 112 | 113 | (test "numbero-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (numbero x) 117 | (== `(,x ,y) q) 118 | (numbero x))) 119 | '(((_.0 _.1) (num _.0)))) 120 | 121 | (test "numbero-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (numbero w) 126 | (numbero z))) 127 | '(_.0)) 128 | 129 | (test "numbero-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (numbero w) 134 | (numbero z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (num _.0 _.3)))) 139 | 140 | (test "numbero-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (numbero w) 145 | (numbero y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (num _.0 _.2)))) 150 | 151 | (test "numbero-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (numbero w) 156 | (numbero y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (num _.0)))) 162 | 163 | (test "numbero-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(a . b)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 a) (_.1 b)))))) 169 | 170 | (test "numbero-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(a . b)) 174 | (numbero w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (num _.0)))) 177 | 178 | (test "numbero-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (numbero w) 182 | (=/= `(,w . ,x) `(a . b)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (num _.0)))) 185 | 186 | (test "numbero-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (numbero w) 190 | (=/= `(a . b) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (num _.0)))) 193 | 194 | (test "numbero-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (numbero w) 198 | (=/= `(a . ,x) `(,w . b)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (num _.0)))) 201 | 202 | (test "numbero-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (numbero w) 206 | (=/= `(5 . ,x) `(,w . b)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 b))) (num _.0)))) 209 | 210 | (test "numbero-31" 211 | (run* (q) 212 | (fresh (x y z a b) 213 | (numbero x) 214 | (numbero y) 215 | (numbero z) 216 | (numbero a) 217 | (numbero b) 218 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 219 | (== q `(,x ,y ,z ,a ,b)))) 220 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 221 | 222 | (test "numbero-32" 223 | (run* (q) 224 | (fresh (x y z a b) 225 | (== q `(,x ,y ,z ,a ,b)) 226 | (== `(,y ,z ,x ,b) `(,z ,x ,y ,a)) 227 | (numbero x) 228 | (numbero a))) 229 | '(((_.0 _.0 _.0 _.1 _.1) (num _.0 _.1)))) 230 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/simple-interp.scm: -------------------------------------------------------------------------------- 1 | (define evalo 2 | (lambda (expr val) 3 | (eval-expro expr '() val))) 4 | 5 | (define eval-expro 6 | (lambda (expr env val) 7 | (conde 8 | ((fresh (rator rand x body env^ a) 9 | (== `(,rator ,rand) expr) 10 | (eval-expro rator env `(closure ,x ,body ,env^)) 11 | (eval-expro rand env a) 12 | (eval-expro body `((,x . ,a) . ,env^) val))) 13 | ((fresh (x body) 14 | (== `(lambda (,x) ,body) expr) 15 | (symbolo x) 16 | (== `(closure ,x ,body ,env) val) 17 | (not-in-envo 'lambda env))) 18 | ((symbolo expr) (lookupo expr env val))))) 19 | 20 | (define not-in-envo 21 | (lambda (x env) 22 | (conde 23 | ((== '() env)) 24 | ((fresh (y v rest) 25 | (== `((,y . ,v) . ,rest) env) 26 | (=/= y x) 27 | (not-in-envo x rest)))))) 28 | 29 | (define lookupo 30 | (lambda (x env t) 31 | (conde 32 | ((fresh (y v rest) 33 | (== `((,y . ,v) . ,rest) env) (== y x) 34 | (== v t))) 35 | ((fresh (y v rest) 36 | (== `((,y . ,v) . ,rest) env) (=/= y x) 37 | (lookupo x rest t)))))) 38 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/symbolo-numbero-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-numbero-1" 2 | (run* (q) (symbolo q) (numbero q)) 3 | '()) 4 | 5 | (test "symbolo-numbero-2" 6 | (run* (q) (numbero q) (symbolo q)) 7 | '()) 8 | 9 | (test "symbolo-numbero-3" 10 | (run* (q) 11 | (fresh (x) 12 | (numbero x) 13 | (symbolo x))) 14 | '()) 15 | 16 | (test "symbolo-numbero-4" 17 | (run* (q) 18 | (fresh (x) 19 | (symbolo x) 20 | (numbero x))) 21 | '()) 22 | 23 | (test "symbolo-numbero-5" 24 | (run* (q) 25 | (numbero q) 26 | (fresh (x) 27 | (symbolo x) 28 | (== x q))) 29 | '()) 30 | 31 | (test "symbolo-numbero-6" 32 | (run* (q) 33 | (symbolo q) 34 | (fresh (x) 35 | (numbero x) 36 | (== x q))) 37 | '()) 38 | 39 | (test "symbolo-numbero-7" 40 | (run* (q) 41 | (fresh (x) 42 | (numbero x) 43 | (== x q)) 44 | (symbolo q)) 45 | '()) 46 | 47 | (test "symbolo-numbero-7" 48 | (run* (q) 49 | (fresh (x) 50 | (symbolo x) 51 | (== x q)) 52 | (numbero q)) 53 | '()) 54 | 55 | (test "symbolo-numbero-8" 56 | (run* (q) 57 | (fresh (x) 58 | (== x q) 59 | (symbolo x)) 60 | (numbero q)) 61 | '()) 62 | 63 | (test "symbolo-numbero-9" 64 | (run* (q) 65 | (fresh (x) 66 | (== x q) 67 | (numbero x)) 68 | (symbolo q)) 69 | '()) 70 | 71 | (test "symbolo-numbero-10" 72 | (run* (q) 73 | (symbolo q) 74 | (fresh (x) 75 | (numbero x))) 76 | '((_.0 (sym _.0)))) 77 | 78 | (test "symbolo-numbero-11" 79 | (run* (q) 80 | (numbero q) 81 | (fresh (x) 82 | (symbolo x))) 83 | '((_.0 (num _.0)))) 84 | 85 | (test "symbolo-numbero-12" 86 | (run* (q) 87 | (fresh (x y) 88 | (symbolo x) 89 | (== `(,x ,y) q))) 90 | '(((_.0 _.1) (sym _.0)))) 91 | 92 | (test "symbolo-numbero-13" 93 | (run* (q) 94 | (fresh (x y) 95 | (numbero x) 96 | (== `(,x ,y) q))) 97 | '(((_.0 _.1) (num _.0)))) 98 | 99 | (test "symbolo-numbero-14" 100 | (run* (q) 101 | (fresh (x y) 102 | (numbero x) 103 | (symbolo y) 104 | (== `(,x ,y) q))) 105 | '(((_.0 _.1) (num _.0) (sym _.1)))) 106 | 107 | (test "symbolo-numbero-15" 108 | (run* (q) 109 | (fresh (x y) 110 | (numbero x) 111 | (== `(,x ,y) q) 112 | (symbolo y))) 113 | '(((_.0 _.1) (num _.0) (sym _.1)))) 114 | 115 | (test "symbolo-numbero-16" 116 | (run* (q) 117 | (fresh (x y) 118 | (== `(,x ,y) q) 119 | (numbero x) 120 | (symbolo y))) 121 | '(((_.0 _.1) (num _.0) (sym _.1)))) 122 | 123 | (test "symbolo-numbero-17" 124 | (run* (q) 125 | (fresh (x y) 126 | (== `(,x ,y) q) 127 | (numbero x) 128 | (symbolo y)) 129 | (fresh (w z) 130 | (== `(,w ,z) q))) 131 | '(((_.0 _.1) (num _.0) (sym _.1)))) 132 | 133 | (test "symbolo-numbero-18" 134 | (run* (q) 135 | (fresh (x y) 136 | (== `(,x ,y) q) 137 | (numbero x) 138 | (symbolo y)) 139 | (fresh (w z) 140 | (== `(,w ,z) q) 141 | (== w 5))) 142 | '(((5 _.0) (sym _.0)))) 143 | 144 | (test "symbolo-numbero-19" 145 | (run* (q) 146 | (fresh (x y) 147 | (== `(,x ,y) q) 148 | (numbero x) 149 | (symbolo y)) 150 | (fresh (w z) 151 | (== 'a z) 152 | (== `(,w ,z) q))) 153 | '(((_.0 a) (num _.0)))) 154 | 155 | (test "symbolo-numbero-20" 156 | (run* (q) 157 | (fresh (x y) 158 | (== `(,x ,y) q) 159 | (numbero x) 160 | (symbolo y)) 161 | (fresh (w z) 162 | (== `(,w ,z) q) 163 | (== 'a z))) 164 | '(((_.0 a) (num _.0)))) 165 | 166 | (test "symbolo-numbero-21" 167 | (run* (q) 168 | (fresh (x y) 169 | (== `(,x ,y) q) 170 | (=/= `(5 a) q))) 171 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 a)))))) 172 | 173 | (test "symbolo-numbero-22" 174 | (run* (q) 175 | (fresh (x y) 176 | (== `(,x ,y) q) 177 | (=/= `(5 a) q) 178 | (symbolo x))) 179 | '(((_.0 _.1) (sym _.0)))) 180 | 181 | (test "symbolo-numbero-23" 182 | (run* (q) 183 | (fresh (x y) 184 | (== `(,x ,y) q) 185 | (symbolo x) 186 | (=/= `(5 a) q))) 187 | '(((_.0 _.1) (sym _.0)))) 188 | 189 | (test "symbolo-numbero-24" 190 | (run* (q) 191 | (fresh (x y) 192 | (symbolo x) 193 | (== `(,x ,y) q) 194 | (=/= `(5 a) q))) 195 | '(((_.0 _.1) (sym _.0)))) 196 | 197 | (test "symbolo-numbero-25" 198 | (run* (q) 199 | (fresh (x y) 200 | (=/= `(5 a) q) 201 | (symbolo x) 202 | (== `(,x ,y) q))) 203 | '(((_.0 _.1) (sym _.0)))) 204 | 205 | (test "symbolo-numbero-26" 206 | (run* (q) 207 | (fresh (x y) 208 | (=/= `(5 a) q) 209 | (== `(,x ,y) q) 210 | (symbolo x))) 211 | '(((_.0 _.1) (sym _.0)))) 212 | 213 | (test "symbolo-numbero-27" 214 | (run* (q) 215 | (fresh (x y) 216 | (== `(,x ,y) q) 217 | (=/= `(5 a) q) 218 | (numbero y))) 219 | '(((_.0 _.1) (num _.1)))) 220 | 221 | (test "symbolo-numbero-28" 222 | (run* (q) 223 | (fresh (x y) 224 | (== `(,x ,y) q) 225 | (numbero y) 226 | (=/= `(5 a) q))) 227 | '(((_.0 _.1) (num _.1)))) 228 | 229 | (test "symbolo-numbero-29" 230 | (run* (q) 231 | (fresh (x y) 232 | (numbero y) 233 | (== `(,x ,y) q) 234 | (=/= `(5 a) q))) 235 | '(((_.0 _.1) (num _.1)))) 236 | 237 | (test "symbolo-numbero-30" 238 | (run* (q) 239 | (fresh (x y) 240 | (=/= `(5 a) q) 241 | (numbero y) 242 | (== `(,x ,y) q))) 243 | '(((_.0 _.1) (num _.1)))) 244 | 245 | (test "symbolo-numbero-31" 246 | (run* (q) 247 | (fresh (x y) 248 | (=/= `(5 a) q) 249 | (== `(,x ,y) q) 250 | (numbero y))) 251 | '(((_.0 _.1) (num _.1)))) 252 | 253 | (test "symbolo-numbero-32" 254 | (run* (q) 255 | (fresh (x y) 256 | (=/= `(,x ,y) q) 257 | (numbero x) 258 | (symbolo y))) 259 | '(_.0)) 260 | 261 | (test "symbolo-numbero-33" 262 | (run* (q) 263 | (fresh (x y) 264 | (numbero x) 265 | (=/= `(,x ,y) q) 266 | (symbolo y))) 267 | '(_.0)) 268 | 269 | (test "symbolo-numbero-34" 270 | (run* (q) 271 | (fresh (x y) 272 | (numbero x) 273 | (symbolo y) 274 | (=/= `(,x ,y) q))) 275 | '(_.0)) 276 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/symbolo-tests.scm: -------------------------------------------------------------------------------- 1 | (test "symbolo-1" 2 | (run* (q) (symbolo q)) 3 | '((_.0 (sym _.0)))) 4 | 5 | (test "symbolo-2" 6 | (run* (q) (symbolo q) (== 'x q)) 7 | '(x)) 8 | 9 | (test "symbolo-3" 10 | (run* (q) (== 'x q) (symbolo q)) 11 | '(x)) 12 | 13 | (test "symbolo-4" 14 | (run* (q) (== 5 q) (symbolo q)) 15 | '()) 16 | 17 | (test "symbolo-5" 18 | (run* (q) (symbolo q) (== 5 q)) 19 | '()) 20 | 21 | (test "symbolo-6" 22 | (run* (q) (symbolo q) (== `(1 . 2) q)) 23 | '()) 24 | 25 | (test "symbolo-7" 26 | (run* (q) (== `(1 . 2) q) (symbolo q)) 27 | '()) 28 | 29 | (test "symbolo-8" 30 | (run* (q) (fresh (x) (symbolo x))) 31 | '(_.0)) 32 | 33 | (test "symbolo-9" 34 | (run* (q) (fresh (x) (symbolo x))) 35 | '(_.0)) 36 | 37 | (test "symbolo-10" 38 | (run* (q) (fresh (x) (symbolo x) (== x q))) 39 | '((_.0 (sym _.0)))) 40 | 41 | (test "symbolo-11" 42 | (run* (q) (fresh (x) (symbolo q) (== x q) (symbolo x))) 43 | '((_.0 (sym _.0)))) 44 | 45 | (test "symbolo-12" 46 | (run* (q) (fresh (x) (symbolo q) (symbolo x) (== x q))) 47 | '((_.0 (sym _.0)))) 48 | 49 | (test "symbolo-13" 50 | (run* (q) (fresh (x) (== x q) (symbolo q) (symbolo x))) 51 | '((_.0 (sym _.0)))) 52 | 53 | (test "symbolo-14-a" 54 | (run* (q) (fresh (x) (symbolo q) (== 'y x))) 55 | '((_.0 (sym _.0)))) 56 | 57 | (test "symbolo-14-b" 58 | (run* (q) (fresh (x) (symbolo q) (== 'y x) (== x q))) 59 | '(y)) 60 | 61 | (test "symbolo-15" 62 | (run* (q) (fresh (x) (== q x) (symbolo q) (== 5 x))) 63 | '()) 64 | 65 | (test "symbolo-16-a" 66 | (run* (q) (symbolo q) (=/= 5 q)) 67 | '((_.0 (sym _.0)))) 68 | 69 | (test "symbolo-16-b" 70 | (run* (q) (=/= 5 q) (symbolo q)) 71 | '((_.0 (sym _.0)))) 72 | 73 | (test "symbolo-17" 74 | (run* (q) (symbolo q) (=/= `(1 . 2) q)) 75 | '((_.0 (sym _.0)))) 76 | 77 | (test "symbolo-18" 78 | (run* (q) (symbolo q) (=/= 'y q)) 79 | '((_.0 (=/= ((_.0 y))) (sym _.0)))) 80 | 81 | (test "symbolo-19" 82 | (run* (q) 83 | (fresh (x y) 84 | (symbolo x) 85 | (symbolo y) 86 | (== `(,x ,y) q))) 87 | '(((_.0 _.1) (sym _.0 _.1)))) 88 | 89 | (test "symbolo-20" 90 | (run* (q) 91 | (fresh (x y) 92 | (== `(,x ,y) q) 93 | (symbolo x) 94 | (symbolo y))) 95 | '(((_.0 _.1) (sym _.0 _.1)))) 96 | 97 | (test "symbolo-21" 98 | (run* (q) 99 | (fresh (x y) 100 | (== `(,x ,y) q) 101 | (symbolo x) 102 | (symbolo x))) 103 | '(((_.0 _.1) (sym _.0)))) 104 | 105 | (test "symbolo-22" 106 | (run* (q) 107 | (fresh (x y) 108 | (symbolo x) 109 | (symbolo x) 110 | (== `(,x ,y) q))) 111 | '(((_.0 _.1) (sym _.0)))) 112 | 113 | (test "symbolo-23" 114 | (run* (q) 115 | (fresh (x y) 116 | (symbolo x) 117 | (== `(,x ,y) q) 118 | (symbolo x))) 119 | '(((_.0 _.1) (sym _.0)))) 120 | 121 | (test "symbolo-24-a" 122 | (run* (q) 123 | (fresh (w x y z) 124 | (=/= `(,w . ,x) `(,y . ,z)) 125 | (symbolo w) 126 | (symbolo z))) 127 | '(_.0)) 128 | 129 | (test "symbolo-24-b" 130 | (run* (q) 131 | (fresh (w x y z) 132 | (=/= `(,w . ,x) `(,y . ,z)) 133 | (symbolo w) 134 | (symbolo z) 135 | (== `(,w ,x ,y ,z) q))) 136 | '(((_.0 _.1 _.2 _.3) 137 | (=/= ((_.0 _.2) (_.1 _.3))) 138 | (sym _.0 _.3)))) 139 | 140 | (test "symbolo-24-c" 141 | (run* (q) 142 | (fresh (w x y z) 143 | (=/= `(,w . ,x) `(,y . ,z)) 144 | (symbolo w) 145 | (symbolo y) 146 | (== `(,w ,x ,y ,z) q))) 147 | '(((_.0 _.1 _.2 _.3) 148 | (=/= ((_.0 _.2) (_.1 _.3))) 149 | (sym _.0 _.2)))) 150 | 151 | (test "symbolo-24-d" 152 | (run* (q) 153 | (fresh (w x y z) 154 | (=/= `(,w . ,x) `(,y . ,z)) 155 | (symbolo w) 156 | (symbolo y) 157 | (== w y) 158 | (== `(,w ,x ,y ,z) q))) 159 | '(((_.0 _.1 _.0 _.2) 160 | (=/= ((_.1 _.2))) 161 | (sym _.0)))) 162 | 163 | (test "symbolo-25" 164 | (run* (q) 165 | (fresh (w x) 166 | (=/= `(,w . ,x) `(5 . 6)) 167 | (== `(,w ,x) q))) 168 | '(((_.0 _.1) (=/= ((_.0 5) (_.1 6)))))) 169 | 170 | (test "symbolo-26" 171 | (run* (q) 172 | (fresh (w x) 173 | (=/= `(,w . ,x) `(5 . 6)) 174 | (symbolo w) 175 | (== `(,w ,x) q))) 176 | '(((_.0 _.1) (sym _.0)))) 177 | 178 | (test "symbolo-27" 179 | (run* (q) 180 | (fresh (w x) 181 | (symbolo w) 182 | (=/= `(,w . ,x) `(5 . 6)) 183 | (== `(,w ,x) q))) 184 | '(((_.0 _.1) (sym _.0)))) 185 | 186 | (test "symbolo-28" 187 | (run* (q) 188 | (fresh (w x) 189 | (symbolo w) 190 | (=/= `(5 . 6) `(,w . ,x)) 191 | (== `(,w ,x) q))) 192 | '(((_.0 _.1) (sym _.0)))) 193 | 194 | (test "symbolo-29" 195 | (run* (q) 196 | (fresh (w x) 197 | (symbolo w) 198 | (=/= `(5 . ,x) `(,w . 6)) 199 | (== `(,w ,x) q))) 200 | '(((_.0 _.1) (sym _.0)))) 201 | 202 | (test "symbolo-30" 203 | (run* (q) 204 | (fresh (w x) 205 | (symbolo w) 206 | (=/= `(z . ,x) `(,w . 6)) 207 | (== `(,w ,x) q))) 208 | '(((_.0 _.1) (=/= ((_.0 z) (_.1 6))) (sym _.0)))) 209 | 210 | (test "symbolo-31-a" 211 | (run* (q) 212 | (fresh (w x y z) 213 | (== x 5) 214 | (=/= `(,w ,y) `(,x ,z)) 215 | (== w 5) 216 | (== `(,w ,x ,y ,z) q))) 217 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 218 | 219 | (test "symbolo-31-b" 220 | (run* (q) 221 | (fresh (w x y z) 222 | (=/= `(,w ,y) `(,x ,z)) 223 | (== w 5) 224 | (== x 5) 225 | (== `(,w ,x ,y ,z) q))) 226 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 227 | 228 | (test "symbolo-31-c" 229 | (run* (q) 230 | (fresh (w x y z) 231 | (== w 5) 232 | (=/= `(,w ,y) `(,x ,z)) 233 | (== `(,w ,x ,y ,z) q) 234 | (== x 5))) 235 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 236 | 237 | (test "symbolo-31-d" 238 | (run* (q) 239 | (fresh (w x y z) 240 | (== w 5) 241 | (== x 5) 242 | (=/= `(,w ,y) `(,x ,z)) 243 | (== `(,w ,x ,y ,z) q))) 244 | '(((5 5 _.0 _.1) (=/= ((_.0 _.1)))))) 245 | 246 | 247 | (test "symbolo-32-a" 248 | (run* (q) 249 | (fresh (w x y z) 250 | (== x 'a) 251 | (=/= `(,w ,y) `(,x ,z)) 252 | (== w 'a) 253 | (== `(,w ,x ,y ,z) q))) 254 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 255 | 256 | (test "symbolo-32-b" 257 | (run* (q) 258 | (fresh (w x y z) 259 | (=/= `(,w ,y) `(,x ,z)) 260 | (== w 'a) 261 | (== x 'a) 262 | (== `(,w ,x ,y ,z) q))) 263 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 264 | 265 | (test "symbolo-32-c" 266 | (run* (q) 267 | (fresh (w x y z) 268 | (== w 'a) 269 | (=/= `(,w ,y) `(,x ,z)) 270 | (== `(,w ,x ,y ,z) q) 271 | (== x 'a))) 272 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 273 | 274 | (test "symbolo-32-d" 275 | (run* (q) 276 | (fresh (w x y z) 277 | (== w 'a) 278 | (== x 'a) 279 | (=/= `(,w ,y) `(,x ,z)) 280 | (== `(,w ,x ,y ,z) q))) 281 | '(((a a _.0 _.1) (=/= ((_.0 _.1)))))) 282 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/test-all.scm: -------------------------------------------------------------------------------- 1 | (load "test-check.scm") 2 | 3 | (printf "==-tests\n") 4 | (load "==-tests.scm") 5 | 6 | (printf "symbolo-tests\n") 7 | (load "symbolo-tests.scm") 8 | 9 | (printf "numbero-tests\n") 10 | (load "numbero-tests.scm") 11 | 12 | (printf "symbolo-numbero-tests\n") 13 | (load "symbolo-numbero-tests.scm") 14 | 15 | (printf "disequality-tests\n") 16 | (load "disequality-tests.scm") 17 | 18 | (printf "absento-closure-tests\n") 19 | (load "absento-closure-tests.scm") 20 | 21 | (printf "absento-tests\n") 22 | (load "absento-tests.scm") 23 | 24 | (printf "test-infer\n") 25 | (load "test-infer.scm") 26 | 27 | (printf "test-simple-interp\n") 28 | (load "test-simple-interp.scm") 29 | 30 | (printf "test-quines\n") 31 | (load "test-quines.scm") 32 | 33 | (printf "test-numbers\n") 34 | (load "numbers.scm") 35 | (load "test-numbers.scm") 36 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/test-infer.scm: -------------------------------------------------------------------------------- 1 | (define !- 2 | (lambda (exp env t) 3 | (conde 4 | [(symbolo exp) (lookupo exp env t)] 5 | [(fresh (x e t-x t-e) 6 | (== `(lambda (,x) ,e) exp) 7 | (symbolo x) 8 | (not-in-envo 'lambda env) 9 | (== `(-> ,t-x ,t-e) t) 10 | (!- e `((,x . ,t-x) . ,env) t-e))] 11 | [(fresh (rator rand t-x) 12 | (== `(,rator ,rand) exp) 13 | (!- rator env `(-> ,t-x ,t)) 14 | (!- rand env t-x))]))) 15 | 16 | (define lookupo 17 | (lambda (x env t) 18 | (fresh (rest y v) 19 | (== `((,y . ,v) . ,rest) env) 20 | (conde 21 | ((== y x) (== v t)) 22 | ((=/= y x) (lookupo x rest t)))))) 23 | 24 | (define not-in-envo 25 | (lambda (x env) 26 | (conde 27 | ((== '() env)) 28 | ((fresh (y v rest) 29 | (== `((,y . ,v) . ,rest) env) 30 | (=/= y x) 31 | (not-in-envo x rest)))))) 32 | 33 | (test "types" 34 | (run 10 (q) (fresh (t exp) (!- exp '() t) (== `(,exp => ,t) q))) 35 | '((((lambda (_.0) _.0) => (-> _.1 _.1)) (sym _.0)) 36 | (((lambda (_.0) (lambda (_.1) _.1)) 37 | => 38 | (-> _.2 (-> _.3 _.3))) 39 | (=/= ((_.0 lambda))) 40 | (sym _.0 _.1)) 41 | (((lambda (_.0) (lambda (_.1) _.0)) 42 | => 43 | (-> _.2 (-> _.3 _.2))) 44 | (=/= ((_.0 _.1)) ((_.0 lambda))) 45 | (sym _.0 _.1)) 46 | ((((lambda (_.0) _.0) (lambda (_.1) _.1)) => (-> _.2 _.2)) 47 | (sym _.0 _.1)) 48 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.2))) 49 | => 50 | (-> _.3 (-> _.4 (-> _.5 _.5)))) 51 | (=/= ((_.0 lambda)) ((_.1 lambda))) 52 | (sym _.0 _.1 _.2)) 53 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.1))) 54 | => 55 | (-> _.3 (-> _.4 (-> _.5 _.4)))) 56 | (=/= ((_.0 lambda)) ((_.1 _.2)) ((_.1 lambda))) 57 | (sym _.0 _.1 _.2)) 58 | (((lambda (_.0) (_.0 (lambda (_.1) _.1))) 59 | => 60 | (-> (-> (-> _.2 _.2) _.3) _.3)) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1)) 63 | (((lambda (_.0) (lambda (_.1) (lambda (_.2) _.0))) 64 | => 65 | (-> _.3 (-> _.4 (-> _.5 _.3)))) 66 | (=/= ((_.0 _.1)) ((_.0 _.2)) ((_.0 lambda)) ((_.1 lambda))) 67 | (sym _.0 _.1 _.2)) 68 | (((lambda (_.0) (lambda (_.1) (_.1 _.0))) 69 | => 70 | (-> _.2 (-> (-> _.2 _.3) _.3))) 71 | (=/= ((_.0 _.1)) ((_.0 lambda))) 72 | (sym _.0 _.1)) 73 | ((((lambda (_.0) _.0) (lambda (_.1) (lambda (_.2) _.2))) 74 | => 75 | (-> _.3 (-> _.4 _.4))) 76 | (=/= ((_.1 lambda))) 77 | (sym _.0 _.1 _.2)))) 78 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/test-numbers.scm: -------------------------------------------------------------------------------- 1 | (test "test 1" 2 | (run* (q) (*o (build-num 2) (build-num 3) q)) 3 | '((0 1 1))) 4 | 5 | (test "test 2" 6 | (run* (q) 7 | (fresh (n m) 8 | (*o n m (build-num 6)) 9 | (== `(,n ,m) q))) 10 | '(((1) (0 1 1)) ((0 1 1) (1)) ((0 1) (1 1)) ((1 1) (0 1)))) 11 | 12 | (test "sums" 13 | (run 5 (q) 14 | (fresh (x y z) 15 | (pluso x y z) 16 | (== `(,x ,y ,z) q))) 17 | '((_.0 () _.0) 18 | (() (_.0 . _.1) (_.0 . _.1)) 19 | ((1) (1) (0 1)) 20 | ((1) (0 _.0 . _.1) (1 _.0 . _.1)) 21 | ((1) (1 1) (0 0 1)))) 22 | 23 | (test "factors" 24 | (run* (q) 25 | (fresh (x y) 26 | (*o x y (build-num 24)) 27 | (== `(,x ,y ,(build-num 24)) q))) 28 | '(((1) (0 0 0 1 1) (0 0 0 1 1)) 29 | ((0 0 0 1 1) (1) (0 0 0 1 1)) 30 | ((0 1) (0 0 1 1) (0 0 0 1 1)) 31 | ((0 0 1) (0 1 1) (0 0 0 1 1)) 32 | ((0 0 0 1) (1 1) (0 0 0 1 1)) 33 | ((1 1) (0 0 0 1) (0 0 0 1 1)) 34 | ((0 1 1) (0 0 1) (0 0 0 1 1)) 35 | ((0 0 1 1) (0 1) (0 0 0 1 1)))) 36 | 37 | (define number-primo 38 | (lambda (exp env val) 39 | (fresh (n) 40 | (== `(intexp ,n) exp) 41 | (== `(intval ,n) val) 42 | (not-in-envo 'numo env)))) 43 | 44 | (define sub1-primo 45 | (lambda (exp env val) 46 | (fresh (e n n-1) 47 | (== `(sub1 ,e) exp) 48 | (== `(intval ,n-1) val) 49 | (not-in-envo 'sub1 env) 50 | (eval-expo e env `(intval ,n)) 51 | (minuso n '(1) n-1)))) 52 | 53 | (define zero?-primo 54 | (lambda (exp env val) 55 | (fresh (e n) 56 | (== `(zero? ,e) exp) 57 | (conde 58 | ((zeroo n) (== #t val)) 59 | ((poso n) (== #f val))) 60 | (not-in-envo 'zero? env) 61 | (eval-expo e env `(intval ,n))))) 62 | 63 | (define *-primo 64 | (lambda (exp env val) 65 | (fresh (e1 e2 n1 n2 n3) 66 | (== `(* ,e1 ,e2) exp) 67 | (== `(intval ,n3) val) 68 | (not-in-envo '* env) 69 | (eval-expo e1 env `(intval ,n1)) 70 | (eval-expo e2 env `(intval ,n2)) 71 | (*o n1 n2 n3)))) 72 | 73 | (define if-primo 74 | (lambda (exp env val) 75 | (fresh (e1 e2 e3 t) 76 | (== `(if ,e1 ,e2 ,e3) exp) 77 | (not-in-envo 'if env) 78 | (eval-expo e1 env t) 79 | (conde 80 | ((== #t t) (eval-expo e2 env val)) 81 | ((== #f t) (eval-expo e3 env val)))))) 82 | 83 | (define boolean-primo 84 | (lambda (exp env val) 85 | (conde 86 | ((== #t exp) (== #t val)) 87 | ((== #f exp) (== #f val))))) 88 | 89 | (define eval-expo 90 | (lambda (exp env val) 91 | (conde 92 | ((boolean-primo exp env val)) 93 | ((number-primo exp env val)) 94 | ((sub1-primo exp env val)) 95 | ((zero?-primo exp env val)) 96 | ((*-primo exp env val)) 97 | ((if-primo exp env val)) 98 | ((symbolo exp) (lookupo exp env val)) 99 | ((fresh (rator rand x body env^ a) 100 | (== `(,rator ,rand) exp) 101 | (eval-expo rator env `(closure ,x ,body ,env^)) 102 | (eval-expo rand env a) 103 | (eval-expo body `((,x . ,a) . ,env^) val))) 104 | ((fresh (x body) 105 | (== `(lambda (,x) ,body) exp) 106 | (symbolo x) 107 | (== `(closure ,x ,body ,env) val) 108 | (not-in-envo 'lambda env)))))) 109 | 110 | (define not-in-envo 111 | (lambda (x env) 112 | (conde 113 | ((fresh (y v rest) 114 | (== `((,y . ,v) . ,rest) env) 115 | (=/= y x) 116 | (not-in-envo x rest))) 117 | ((== '() env))))) 118 | 119 | (define lookupo 120 | (lambda (x env t) 121 | (fresh (rest y v) 122 | (== `((,y . ,v) . ,rest) env) 123 | (conde 124 | ((== y x) (== v t)) 125 | ((=/= y x) (lookupo x rest t)))))) 126 | 127 | (test "push-down problems 2" 128 | (run* (q) 129 | (fresh (x a d) 130 | (absento 'intval x) 131 | (== 'intval a) 132 | (== `(,a . ,d) x))) 133 | '()) 134 | 135 | (test "push-down problems 3" 136 | (run* (q) 137 | (fresh (x a d) 138 | (== `(,a . ,d) x) 139 | (absento 'intval x) 140 | (== 'intval a))) 141 | '()) 142 | 143 | (test "push-down problems 4" 144 | (run* (q) 145 | (fresh (x a d) 146 | (== `(,a . ,d) x) 147 | (== 'intval a) 148 | (absento 'intval x))) 149 | '()) 150 | 151 | (test "push-down problems 6" 152 | (run* (q) 153 | (fresh (x a d) 154 | (== 'intval a) 155 | (== `(,a . ,d) x) 156 | (absento 'intval x))) 157 | '()) 158 | 159 | (test "push-down problems 1" 160 | (run* (q) 161 | (fresh (x a d) 162 | (absento 'intval x) 163 | (== `(,a . ,d) x) 164 | (== 'intval a))) 165 | '()) 166 | 167 | (test "push-down problems 5" 168 | (run* (q) 169 | (fresh (x a d) 170 | (== 'intval a) 171 | (absento 'intval x) 172 | (== `(,a . ,d) x))) 173 | '()) 174 | 175 | (test "zero?" 176 | (run 1 (q) 177 | (eval-expo `(zero? (sub1 (intexp ,(build-num 1)))) '() q)) 178 | '(#t)) 179 | 180 | (test "*" 181 | (run 1 (q) 182 | (eval-expo `(* (intexp ,(build-num 3)) (intexp ,(build-num 2))) '() `(intval ,(build-num 6)))) 183 | '(_.0)) 184 | 185 | (test "sub1" 186 | (run 1 (q) 187 | (eval-expo q '() `(intval ,(build-num 6))) (== `(sub1 (intexp ,(build-num 7))) q)) 188 | '((sub1 (intexp (1 1 1))))) 189 | 190 | (test "sub1 bigger WAIT a minute" 191 | (run 1 (q) 192 | (eval-expo q '() `(intval ,(build-num 6))) 193 | (== `(sub1 (sub1 (intexp ,(build-num 8)))) q)) 194 | '((sub1 (sub1 (intexp (0 0 0 1)))))) 195 | 196 | (test "sub1 biggest WAIT a minute" 197 | (run 1 (q) 198 | (eval-expo q '() `(intval ,(build-num 6))) 199 | (== `(sub1 (sub1 (sub1 (intexp ,(build-num 9))))) q)) 200 | '((sub1 (sub1 (sub1 (intexp (1 0 0 1))))))) 201 | 202 | (test "lots of programs to make a 6" 203 | (run 12 (q) (eval-expo q '() `(intval ,(build-num 6)))) 204 | '((intexp (0 1 1)) (sub1 (intexp (1 1 1))) 205 | (* (intexp (1)) (intexp (0 1 1))) 206 | (* (intexp (0 1 1)) (intexp (1))) 207 | (if #t (intexp (0 1 1)) _.0) 208 | (* (intexp (0 1)) (intexp (1 1))) 209 | (if #f _.0 (intexp (0 1 1))) 210 | (sub1 (* (intexp (1)) (intexp (1 1 1)))) 211 | (((lambda (_.0) (intexp (0 1 1))) #t) 212 | (=/= ((_.0 numo))) 213 | (sym _.0)) 214 | (sub1 (* (intexp (1 1 1)) (intexp (1)))) 215 | (sub1 (sub1 (intexp (0 0 0 1)))) 216 | (sub1 (if #t (intexp (1 1 1)) _.0)))) 217 | 218 | (define rel-fact5 219 | `((lambda (f) 220 | ((f f) (intexp ,(build-num 5)))) 221 | (lambda (f) 222 | (lambda (n) 223 | (if (zero? n) 224 | (intexp ,(build-num 1)) 225 | (* n ((f f) (sub1 n)))))))) 226 | 227 | (test "rel-fact5" 228 | (run* (q) (eval-expo rel-fact5 '() q)) 229 | `((intval ,(build-num 120)))) 230 | 231 | (test "rel-fact5-backwards" 232 | (run 1 (q) 233 | (eval-expo 234 | `((lambda (f) 235 | ((f ,q) (intexp ,(build-num 5)))) 236 | (lambda (f) 237 | (lambda (n) 238 | (if (zero? n) 239 | (intexp ,(build-num 1)) 240 | (* n ((f f) (sub1 n))))))) 241 | '() 242 | `(intval ,(build-num 120)))) 243 | `(f)) 244 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/faster-miniKanren/test-simple-interp.scm: -------------------------------------------------------------------------------- 1 | (load "simple-interp.scm") 2 | 3 | (test "running backwards" 4 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 5 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 6 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 7 | (((lambda (x) (lambda (y) x)) 8 | ((lambda (_.0) _.0) (lambda (z) z))) 9 | (sym _.0)) 10 | (((lambda (_.0) _.0) 11 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 12 | (sym _.0)) 13 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 14 | (lambda (z) z)) 15 | (sym _.0)))) 16 | 17 | (define lookupo 18 | (lambda (x env t) 19 | (fresh (rest y v) 20 | (== `((,y . ,v) . ,rest) env) 21 | (conde 22 | ((== y x) (== v t)) 23 | ((=/= y x) (lookupo x rest t)))))) 24 | 25 | (test "eval-exp-lc 1" 26 | (run* (q) (evalo '(((lambda (x) (lambda (y) x)) (lambda (z) z)) (lambda (a) a)) q)) 27 | '((closure z z ()))) 28 | 29 | (test "eval-exp-lc 2" 30 | (run* (q) (evalo '((lambda (x) (lambda (y) x)) (lambda (z) z)) q)) 31 | '((closure y x ((x . (closure z z ())))))) 32 | 33 | (test "running backwards" 34 | (run 5 (q) (evalo q '(closure y x ((x . (closure z z ())))))) 35 | '(((lambda (x) (lambda (y) x)) (lambda (z) z)) 36 | ((lambda (x) (x (lambda (y) x))) (lambda (z) z)) 37 | (((lambda (x) (lambda (y) x)) 38 | ((lambda (_.0) _.0) (lambda (z) z))) 39 | (sym _.0)) 40 | ((((lambda (_.0) _.0) (lambda (x) (lambda (y) x))) 41 | (lambda (z) z)) 42 | (sym _.0)) 43 | (((lambda (_.0) _.0) 44 | ((lambda (x) (lambda (y) x)) (lambda (z) z))) 45 | (sym _.0)))) 46 | 47 | (test "fully-running-backwards" 48 | (run 5 (q) 49 | (fresh (e v) 50 | (evalo e v) 51 | (== `(,e ==> ,v) q))) 52 | '((((lambda (_.0) _.1) 53 | ==> (closure _.0 _.1 ())) (sym _.0)) 54 | ((((lambda (_.0) _.0) (lambda (_.1) _.2)) 55 | ==> 56 | (closure _.1 _.2 ())) 57 | (sym _.0 _.1)) 58 | ((((lambda (_.0) (lambda (_.1) _.2)) (lambda (_.3) _.4)) 59 | ==> 60 | (closure _.1 _.2 ((_.0 . (closure _.3 _.4 ()))))) 61 | (=/= ((_.0 lambda))) 62 | (sym _.0 _.1 _.3)) 63 | ((((lambda (_.0) (_.0 _.0)) (lambda (_.1) _.1)) 64 | ==> 65 | (closure _.1 _.1 ())) 66 | (sym _.0 _.1)) 67 | ((((lambda (_.0) (_.0 _.0)) 68 | (lambda (_.1) (lambda (_.2) _.3))) 69 | ==> 70 | (closure _.2 _.3 ((_.1 . (closure _.1 (lambda (_.2) _.3) ()))))) 71 | (=/= ((_.1 lambda))) 72 | (sym _.0 _.1 _.2)))) 73 | -------------------------------------------------------------------------------- /code/intro-hangouts/intro-hangout-9/hangout-9.scm: -------------------------------------------------------------------------------- 1 | (load "faster-miniKanren/mk-vicare.scm") 2 | (load "faster-miniKanren/mk.scm") 3 | 4 | 5 | (define rembero 6 | (lambda (x ls ls-x) 7 | (conde 8 | [(== '() ls) (== '() ls-x)] 9 | [(fresh (d) 10 | (== `(,x . ,d) ls) 11 | (== d ls-x))] 12 | [(fresh (a d res) 13 | (== `(,a . ,d) ls) 14 | (=/= x a) 15 | (== (cons a res) ls-x) 16 | (rembero x d res))]))) 17 | 18 | (define rembero 19 | (lambda (x ls ls-x) 20 | (conde 21 | [(== '() ls) (== '() ls-x)] 22 | [(fresh (a d) 23 | (== `(,a . ,d) ls) 24 | (== x a) 25 | (== d ls-x))] 26 | [(fresh (a d res) 27 | (== `(,a . ,d) ls) 28 | (=/= x a) 29 | (== (cons a res) ls-x) 30 | (rembero x d res))]))) 31 | 32 | (define rembero 33 | (lambda (x ls ls-x) 34 | (conde 35 | [(== '() ls) (== '() ls-x)] 36 | [(fresh (a d) 37 | (== `(,a . ,d) ls) 38 | (conde 39 | [(== x a) (== d ls-x)] 40 | [(=/= x a) 41 | (fresh (res) 42 | (== (cons a res) ls-x) 43 | (rembero x d res))]))]))) 44 | 45 | 46 | ;; x is a symbol [var] 47 | ;; (lambda (,x) ,e) [lambda/abstraction] 48 | ;; (,e1 ,e2) [application] 49 | 50 | (define parseo 51 | (lambda (expr) 52 | (conde 53 | [(numbero expr)] 54 | [(symbolo expr)] 55 | [(fresh (x e) 56 | (== `(lambda (,x) ,e) expr) 57 | (symbolo x) 58 | (parseo e))] 59 | [(fresh (x e body) 60 | (== `(let ((,x ,e)) ,body) expr) 61 | (symbolo x) 62 | (parseo e) 63 | (parseo body))] 64 | [(fresh (e1 e2) 65 | (== `(,e1 ,e2) expr) 66 | (parseo e1) 67 | (parseo e2))]))) 68 | 69 | (define parseo 70 | (lambda (expr legal) 71 | (conde 72 | [(numbero expr) (== #f legal)] 73 | [(symbolo expr) (== #t legal)] 74 | [(fresh (e l) 75 | (== `(lambda () ,e) expr) 76 | (== #f legal) 77 | (parseo e l))] 78 | [(fresh (x y z* e l) 79 | (== `(lambda (,x ,y . ,z*) ,e) expr) 80 | (== #f legal) 81 | (parseo e l))] 82 | [(fresh (x e) 83 | (== `(lambda (,x) ,e) expr) 84 | (symbolo x) 85 | (conde 86 | [(== #t legal) (parseo e #t)] 87 | [(== #f legal) (parseo e #f)]))] 88 | [(fresh (e1 e2 l) 89 | (== `(,e1 ,e2) expr) 90 | (conde 91 | [(== #t legal) 92 | (parseo e1 #t) 93 | (parseo e2 #t)] 94 | [(== #f legal) 95 | (parseo e1 #f) 96 | (parseo e2 l)] 97 | [(== #f legal) 98 | (parseo e1 #t) 99 | (parseo e2 #f)]))]))) 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | #!eof 109 | 110 | 111 | ;; (member? 'x '(y x z)) => #t 112 | ;; (member? 'x '(y w z)) => #f 113 | 114 | ;; (rember 'x '()) => () 115 | ;; (rember 'x '(y x z)) => (y z) 116 | ;; (rember 'x '(x y z)) => (y z) 117 | ;; (rember 'x '(y x z x)) => (y z x) 118 | ;; (rember 'x '(x y z x)) => (y z x) 119 | ;; (rember 'v '(y x z x)) => (y x z x) 120 | 121 | ;; simple, original rember 122 | (define rember 123 | (lambda (x ls) 124 | (cond 125 | [(null? ls) '()] 126 | [(eqv? (car ls) x) (cdr ls)] 127 | [else (cons (car ls) (rember x (cdr ls)))]))) 128 | 129 | (define not-eqv? 130 | (lambda (v1 v2) 131 | (not (eqv? v1 v2)))) 132 | 133 | ;; add Dijkstra guards 134 | (define rember 135 | (lambda (x ls) 136 | (cond 137 | [(null? ls) '()] 138 | [(and (pair? ls) 139 | (eqv? (car ls) x)) 140 | (cdr ls)] 141 | [(and (pair? ls) 142 | (not-eqv? (car ls) x)) 143 | (cons (car ls) (rember x (cdr ls)))]))) 144 | 145 | ;; unnesting 146 | (define rember 147 | (lambda (x ls) 148 | (cond 149 | [(let ((pt (pair? ls))) 150 | (and pt 151 | (let ((a (car ls))) 152 | (let ((net (not-eqv? a x))) 153 | net)))) 154 | (let ((d (cdr ls))) 155 | (let ((a (car ls))) 156 | (let ((res (rember x d))) 157 | (cons a res))))] 158 | [(let ((pt (pair? ls))) 159 | (and pt 160 | (let ((a (car ls))) 161 | (let ((et (eqv? a x))) 162 | et)))) 163 | (cdr ls)] 164 | [(null? ls) '()]))) 165 | 166 | ;; exercises: 167 | ;; 1. define 'multi-rember': removes *all* occurrences of 'x' from 'ls' 168 | ;; 2. define 'multi-rembero' in miniKanren 169 | ;; 3. define 'rember*': removes *all* 'x's from a deeply-nested list 170 | ;; 4. define 'rember*o' 171 | --------------------------------------------------------------------------------