PageRenderTime 312ms CodeModel.GetById 121ms app.highlight 132ms RepoModel.GetById 29ms app.codeStats 0ms

/demos/mk-mk-c.html

http://github.com/yinwang0/ydiff
HTML | 969 lines | 824 code | 145 blank | 0 comment | 0 complexity | 4e6381d0095b93c34756ca7e3bf65390 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

  1<html>
  2<head>
  3<META http-equiv="Content-Type" content="text/html; charset=utf-8">
  4<LINK href="diff-s.css" rel="stylesheet" type="text/css">
  5<script type="text/javascript" src="nav-div.js"></script>
  6</head>
  7<body>
  8<div id="left" class="src">
  9<pre>
 10<a id='leftstart' tid='rightstart'></a>
 11<a id='841' tid='842' class='u'>;;; This file was generated by writeminikanren.pl
 12</a><a id='843' tid='844' class='u'>;;; Generated at 2007-10-25 15:24:42
 13</a>
 14(<a id='387' tid='388' class='u'>define-syntax</a> <a id='389' tid='390' class='u'>lambdag@</a>
 15  <span class='d'>(syntax-rules ()
 16    ((_ (p) e) (lambda (p) e)))</span>)
 17
 18(<a id='383' tid='384' class='u'>define-syntax</a> <a id='385' tid='386' class='u'>lambdaf@</a>
 19  <span class='d'>(syntax-rules ()
 20    ((_ () e) (lambda () e)))</span>)
 21
 22(<a id='545' tid='546' class='u'>define-syntax</a> <a id='547' tid='548' class='u'>run*</a>
 23  (<a id='549' tid='550' class='u'>syntax-rules</a> ()
 24    ((<a id='551' tid='552' class='u'>_</a> (<a id='553' tid='554' class='u'>x</a>) <a id='555' tid='556' class='u'>g</a> <a id='557' tid='558' class='u'>...</a>) (<a id='559' tid='560' class='u'>run</a> <a id='561' tid='562' class='u'>#f</a> (<a id='563' tid='564' class='u'>x</a>) <a id='565' tid='566' class='u'>g</a> <a id='567' tid='568' class='u'>...</a>))))
 25
 26(<a id='527' tid='528' class='u'>define-syntax</a> <a id='529' tid='530' class='u'>rhs</a>
 27  (<a id='531' tid='532' class='u'>syntax-rules</a> ()
 28    ((<a id='533' tid='534' class='u'>_</a> <a id='535' tid='536' class='u'>x</a>) (<a id='537' tid='538' class='u'>cdr</a> <a id='539' tid='540' class='u'>x</a>))))
 29
 30(<a id='391' tid='392' class='u'>define-syntax</a> <a id='393' tid='394' class='u'>lhs</a>
 31  (<a id='395' tid='396' class='u'>syntax-rules</a> ()
 32    ((<a id='397' tid='398' class='u'>_</a> <a id='399' tid='400' class='u'>x</a>) (<a id='401' tid='402' class='u'>car</a> <a id='403' tid='404' class='u'>x</a>))))
 33
 34(<a id='569' tid='570' class='u'>define-syntax</a> <a id='571' tid='572' class='u'>size-s</a>
 35  (<a id='573' tid='574' class='u'>syntax-rules</a> ()
 36    ((<a id='575' tid='576' class='u'>_</a> <a id='577' tid='578' class='u'>x</a>) (<a id='579' tid='580' class='u'>length</a> <a id='581' tid='582' class='u'>x</a>))))
 37
 38(<a id='713' tid='714' class='u'>define-syntax</a> <a id='715' tid='716' class='u'>var</a>
 39  (<a id='717' tid='718' class='u'>syntax-rules</a> ()
 40    ((<a id='719' tid='720' class='u'>_</a> <a id='721' tid='722' class='u'>x</a>) (<a id='723' tid='724' class='u'>vector</a> <a id='725' tid='726' class='u'>x</a>))))
 41
 42(<a id='727' tid='728' class='u'>define-syntax</a> <a id='729' tid='730' class='u'>var?</a>
 43  (<a id='731' tid='732' class='u'>syntax-rules</a> ()
 44    ((<a id='733' tid='734' class='u'>_</a> <a id='735' tid='736' class='u'>x</a>) (<a id='737' tid='738' class='u'>vector?</a> <a id='739' tid='740' class='u'>x</a>))))
 45
 46
 47(<a id='285' tid='286' class='u'>define</a> <a id='287' tid='288' class='u'>empty-s</a> <a id='289' tid='290' class='u'>&#39;</a>())
 48
 49(<a id='741' tid='742' class='u'>define</a> <a id='743' tid='744' class='u'>walk</a>
 50  (<a id='745' tid='746' class='u'>lambda</a> (<a id='747' tid='748' class='u'>v</a> <a id='749' tid='750' class='u'>s</a>)
 51    (<a id='751' tid='752' class='u'>cond</a>
 52      ((<a id='753' tid='754' class='u'>var?</a> <a id='755' tid='756' class='u'>v</a>)
 53       (<a id='757' tid='758' class='u'>let</a> ((<a id='759' tid='760' class='u'>a</a> (<a id='761' tid='762' class='u'>assq</a> <a id='763' tid='764' class='u'>v</a> <a id='765' tid='766' class='u'>s</a>)))
 54         (<a id='767' tid='768' class='u'>cond</a>
 55           (<a id='769' tid='770' class='u'>a</a> (<a id='771' tid='772' class='u'>walk</a> (<a id='773' tid='774' class='u'>rhs</a> <a id='775' tid='776' class='u'>a</a>) <a id='777' tid='778' class='u'>s</a>))
 56           (<a id='779' tid='780' class='u'>else</a> <a id='781' tid='782' class='u'>v</a>))))
 57      (<a id='783' tid='784' class='u'>else</a> <a id='785' tid='786' class='u'>v</a>))))
 58
 59(<a id='295' tid='296' class='u'>define</a> <a id='297' tid='298' class='u'>ext-s</a>
 60  (<a id='299' tid='300' class='u'>lambda</a> (<a id='301' tid='302' class='u'>x</a> <a id='303' tid='304' class='u'>v</a> <a id='305' tid='306' class='u'>s</a>)
 61    (<a id='307' tid='308' class='u'>cons</a> <a id='309' tid='310' class='u'>`</a>(<a id='311' tid='312' class='u'>,</a><a id='313' tid='314' class='u'>x</a> <a id='315' tid='316' class='u'>.</a> <a id='317' tid='318' class='u'>,</a><a id='319' tid='320' class='u'>v</a>) <a id='321' tid='322' class='u'>s</a>)))
 62
 63(<a id='591' tid='592' class='u'>define</a> <a id='593' tid='594' class='u'>unify</a>
 64  <span class='d'>(lambda (v w s)
 65    (let ((v (walk v s))
 66          (w (walk w s)))
 67      (cond
 68        ((eq? v w) s)
 69        ((var? v) (ext-s v w s))
 70        ((var? w) (ext-s w v s))
 71        ((and (pair? v) (pair? w))
 72         (let ((s (unify (car v) (car w) s)))
 73           (and s (unify (cdr v) (cdr w) s))))
 74        ((equal? v w) s)
 75        (else #f))))</span>)
 76
 77(<a id='595' tid='596' class='u'>define</a> <a id='597' tid='598' class='u'>unify-check</a>
 78  (<a id='599' tid='600' class='u'>lambda</a> (<a id='601' tid='602' class='u'>u</a> <a id='603' tid='604' class='u'>v</a> <a id='605' tid='606' class='u'>s</a>)
 79    (<a id='607' tid='608' class='u'>let</a> ((<a id='609' tid='610' class='u'>u</a> (<a id='611' tid='612' class='u'>walk</a> <a id='613' tid='614' class='u'>u</a> <a id='615' tid='616' class='u'>s</a>))
 80          (<a id='617' tid='618' class='u'>v</a> (<a id='619' tid='620' class='u'>walk</a> <a id='621' tid='622' class='u'>v</a> <a id='623' tid='624' class='u'>s</a>)))
 81      (<a id='625' tid='626' class='u'>cond</a>
 82        ((<a id='627' tid='628' class='u'>eq?</a> <a id='629' tid='630' class='u'>u</a> <a id='631' tid='632' class='u'>v</a>) <a id='633' tid='634' class='u'>s</a>)
 83        ((<a id='635' tid='636' class='u'>var?</a> <a id='637' tid='638' class='u'>u</a>) (<a id='639' tid='640' class='u'>ext-s-check</a> <a id='641' tid='642' class='u'>u</a> <a id='643' tid='644' class='u'>v</a> <a id='645' tid='646' class='u'>s</a>))
 84        ((<a id='647' tid='648' class='u'>var?</a> <a id='649' tid='650' class='u'>v</a>) (<a id='651' tid='652' class='u'>ext-s-check</a> <a id='653' tid='654' class='u'>v</a> <a id='655' tid='656' class='u'>u</a> <a id='657' tid='658' class='u'>s</a>))
 85        ((<a id='659' tid='660' class='u'>and</a> (<a id='661' tid='662' class='u'>pair?</a> <a id='663' tid='664' class='u'>u</a>) (<a id='665' tid='666' class='u'>pair?</a> <a id='667' tid='668' class='u'>v</a>))
 86         (<a id='669' tid='670' class='u'>let</a> ((<a id='671' tid='672' class='u'>s</a> (<a id='673' tid='674' class='u'>unify-check</a> 
 87                    (<a id='675' tid='676' class='u'>car</a> <a id='677' tid='678' class='u'>u</a>) (<a id='679' tid='680' class='u'>car</a> <a id='681' tid='682' class='u'>v</a>) <a id='683' tid='684' class='u'>s</a>)))
 88           (<a id='685' tid='686' class='u'>and</a> <a id='687' tid='688' class='u'>s</a> (<a id='689' tid='690' class='u'>unify-check</a> 
 89                    (<a id='691' tid='692' class='u'>cdr</a> <a id='693' tid='694' class='u'>u</a>) (<a id='695' tid='696' class='u'>cdr</a> <a id='697' tid='698' class='u'>v</a>) <a id='699' tid='700' class='u'>s</a>))))
 90        ((<a id='701' tid='702' class='u'>equal?</a> <a id='703' tid='704' class='u'>u</a> <a id='705' tid='706' class='u'>v</a>) <a id='707' tid='708' class='u'>s</a>)
 91        (<a id='709' tid='710' class='u'>else</a> <a id='711' tid='712' class='u'>#f</a>)))))
 92
 93 
 94(<a id='323' tid='324' class='u'>define</a> <a id='325' tid='326' class='u'>ext-s-check</a>
 95  (<a id='327' tid='328' class='u'>lambda</a> (<a id='329' tid='330' class='u'>x</a> <a id='331' tid='332' class='u'>v</a> <a id='333' tid='334' class='u'>s</a>)
 96    (<a id='335' tid='336' class='u'>cond</a>
 97      ((<a id='337' tid='338' class='u'>occurs-check</a> <a id='339' tid='340' class='u'>x</a> <a id='341' tid='342' class='u'>v</a> <a id='343' tid='344' class='u'>s</a>) <a id='345' tid='346' class='u'>#f</a>)
 98      (<a id='347' tid='348' class='u'>else</a> (<a id='349' tid='350' class='u'>ext-s</a> <a id='351' tid='352' class='u'>x</a> <a id='353' tid='354' class='u'>v</a> <a id='355' tid='356' class='u'>s</a>)))))
 99
100(<a id='405' tid='406' class='u'>define</a> <a id='407' tid='408' class='u'>occurs-check</a>
101  (<a id='409' tid='410' class='u'>lambda</a> (<a id='411' tid='412' class='u'>x</a> <a id='413' tid='414' class='u'>v</a> <a id='415' tid='416' class='u'>s</a>)
102    (<a id='417' tid='418' class='u'>let</a> ((<a id='419' tid='420' class='u'>v</a> (<a id='421' tid='422' class='u'>walk</a> <a id='423' tid='424' class='u'>v</a> <a id='425' tid='426' class='u'>s</a>)))
103      (<a id='427' tid='428' class='u'>cond</a>
104        ((<a id='429' tid='430' class='u'>var?</a> <a id='431' tid='432' class='u'>v</a>) (<a id='433' tid='434' class='u'>eq?</a> <a id='435' tid='436' class='u'>v</a> <a id='437' tid='438' class='u'>x</a>))
105        ((<a id='439' tid='440' class='u'>pair?</a> <a id='441' tid='442' class='u'>v</a>) 
106         (<a id='443' tid='444' class='u'>or</a> 
107           (<a id='445' tid='446' class='u'>occurs-check</a> <a id='447' tid='448' class='u'>x</a> (<a id='449' tid='450' class='u'>car</a> <a id='451' tid='452' class='u'>v</a>) <a id='453' tid='454' class='u'>s</a>)
108           (<a id='455' tid='456' class='u'>occurs-check</a> <a id='457' tid='458' class='u'>x</a> (<a id='459' tid='460' class='u'>cdr</a> <a id='461' tid='462' class='u'>v</a>) <a id='463' tid='464' class='u'>s</a>)))
109        (<a id='465' tid='466' class='u'>else</a> <a id='467' tid='468' class='u'>#f</a>)))))
110
111(<a id='787' tid='788' class='u'>define</a> <a id='789' tid='790' class='u'>walk*</a>
112  (<a id='791' tid='792' class='u'>lambda</a> (<a id='793' tid='794' class='u'>w</a> <a id='795' tid='796' class='u'>s</a>)
113    (<a id='797' tid='798' class='u'>let</a> ((<a id='799' tid='800' class='u'>v</a> (<a id='801' tid='802' class='u'>walk</a> <a id='803' tid='804' class='u'>w</a> <a id='805' tid='806' class='u'>s</a>)))
114      (<a id='807' tid='808' class='u'>cond</a>
115        ((<a id='809' tid='810' class='u'>var?</a> <a id='811' tid='812' class='u'>v</a>) <a id='813' tid='814' class='u'>v</a>)
116        ((<a id='815' tid='816' class='u'>pair?</a> <a id='817' tid='818' class='u'>v</a>)
117         (<a id='819' tid='820' class='u'>cons</a>
118           (<a id='821' tid='822' class='u'>walk*</a> (<a id='823' tid='824' class='u'>car</a> <a id='825' tid='826' class='u'>v</a>) <a id='827' tid='828' class='u'>s</a>)
119           (<a id='829' tid='830' class='u'>walk*</a> (<a id='831' tid='832' class='u'>cdr</a> <a id='833' tid='834' class='u'>v</a>) <a id='835' tid='836' class='u'>s</a>)))
120        (<a id='837' tid='838' class='u'>else</a> <a id='839' tid='840' class='u'>v</a>)))))
121
122(<a id='523' tid='524' class='u'>define</a> <a id='525' tid='526' class='u'>reify-s</a>
123  (<span class='d'>lambda</span> <span class='d'>(v s)</span>
124    (<a id='37' tid='38' class='m'>let</a> ((<a id='39' tid='40' class='m'>v</a> (<a id='41' tid='42' class='m'>walk</a> <a id='43' tid='44' class='m'>v</a> <a id='45' tid='46' class='m'>s</a>)))
125      (<a id='47' tid='48' class='m'>cond</a>
126        ((<a id='49' tid='50' class='m'>var?</a> <a id='51' tid='52' class='m'>v</a>)
127         (<a id='53' tid='54' class='m'>ext-s</a> <a id='55' tid='56' class='m'>v</a> (<a id='57' tid='58' class='m'>reify-name</a> (<a id='59' tid='60' class='m'>size-s</a> <a id='61' tid='62' class='m'>s</a>)) <a id='63' tid='64' class='m'>s</a>))
128        ((<a id='65' tid='66' class='m'>pair?</a> <a id='67' tid='68' class='m'>v</a>) (<a id='69' tid='70' class='m'>reify-s</a> (<a id='71' tid='72' class='m'>cdr</a> <a id='73' tid='74' class='m'>v</a>)
129                     (<a id='75' tid='76' class='m'>reify-s</a> (<a id='77' tid='78' class='m'>car</a> <a id='79' tid='80' class='m'>v</a>) <a id='81' tid='82' class='m'>s</a>)))
130        (<a id='83' tid='84' class='m'>else</a> <a id='85' tid='86' class='m'>s</a>)))))
131
132(<a id='503' tid='504' class='u'>define</a> <a id='505' tid='506' class='u'>reify-name</a>
133  (<a id='507' tid='508' class='u'>lambda</a> (<a id='509' tid='510' class='u'>n</a>)
134    (<a id='511' tid='512' class='u'>string-&gt;symbol</a>
135      (<a id='513' tid='514' class='u'>string-append</a> <a id='515' tid='516' class='u'>&quot;_&quot;</a> <a id='517' tid='518' class='u'>&quot;.&quot;</a> (<a id='519' tid='520' class='u'>number-&gt;string</a> <a id='521' tid='522' class='u'>n</a>)))))
136
137(<a id='473' tid='474' class='u'>define</a> <a id='475' tid='476' class='u'>reify</a>
138  (<a id='477' tid='478' class='u'>lambda</a> (<a id='479' tid='480' class='u'>v</a> <a id='481' tid='482' class='u'>s</a>)
139    (<a id='483' tid='484' class='u'>let</a> ((<a id='485' tid='486' class='u'>v</a> (<a id='487' tid='488' class='u'>walk*</a> <a id='489' tid='490' class='u'>v</a> <a id='491' tid='492' class='u'>s</a>)))
140      (<a id='493' tid='494' class='u'>walk*</a> <a id='495' tid='496' class='u'>v</a> (<a id='497' tid='498' class='u'>reify-s</a> <a id='499' tid='500' class='u'>v</a> <a id='501' tid='502' class='u'>empty-s</a>)))))
141
142(<a id='177' tid='178' class='u'>define</a> <a id='179' tid='180' class='u'>==</a> 
143  <span class='d'>(lambda (u v)
144    (lambdag@ (s) (unify u v s)))</span>)
145
146<span class='d'>(define ==-check
147  (lambda (v w)
148    (lambdag@ (s)
149      (unify-check v w s))))</span>
150
151<span class='d'>(define-syntax mzero 
152  (syntax-rules () ((_) #f)))</span>
153
154(<a id='369' tid='370' class='u'>define-syntax</a> <a id='371' tid='372' class='u'>inc</a> 
155  (<a id='373' tid='374' class='u'>syntax-rules</a> () ((<a id='375' tid='376' class='u'>_</a> <a id='377' tid='378' class='u'>e</a>) (<a id='379' tid='380' class='u'>lambdaf@</a> () <a id='381' tid='382' class='u'>e</a>))))
156
157<span class='d'>(define-syntax unit 
158  (syntax-rules () ((_ a) a)))</span>
159
160<span class='d'>(define-syntax choice 
161  (syntax-rules () ((_ a f) (cons a f))))</span>
162 
163<span class='d'>(define-syntax case-inf
164  (syntax-rules ()
165    ((_ e (() e0) ((f^) e1) ((a^) e2) ((a f) e3))
166     (let ((a-inf e))
167       (cond
168         ((not a-inf) e0)
169         ((procedure? a-inf) (let ((f^ a-inf)) e1))
170         ((not (and (pair? a-inf)
171                    (procedure? (cdr a-inf))))
172          (let ((a^ a-inf)) e2))
173         (else (let ((a (car a-inf)) (f (cdr a-inf))) 
174                 e3)))))))</span>
175
176(<a id='541' tid='542' class='u'>define-syntax</a> <a id='543' tid='544' class='u'>run</a>
177  (<a id='23' tid='24' class='m'>syntax-rules</a> ()
178    ((<a id='25' tid='26' class='m'>_</a> <a id='27' tid='28' class='m'>n</a> (<a id='29' tid='30' class='m'>x</a>) <a id='31' tid='32' class='m'>g0</a> <a id='33' tid='34' class='m'>g</a> <a id='35' tid='36' class='m'>...</a>)
179     <span class='d'>(take n
180       (lambdaf@ ()
181         ((exist (x) g0 g ... 
182            (lambdag@ (s)
183              (cons (reify x s) &#39;())))
184          empty-s)))</span>)))
185 
186(<a id='587' tid='588' class='u'>define</a> <a id='589' tid='590' class='u'>take</a>
187  (<span class='d'>lambda</span> <span class='d'>(n f)</span>
188    (<a id='1' tid='2' class='m'>if</a> (<a id='3' tid='4' class='m'>and</a> <a id='5' tid='6' class='m'>n</a> (<a id='7' tid='8' class='m'>zero?</a> <a id='9' tid='10' class='m'>n</a>)) 
189      <a id='11' tid='12' class='m'>&#39;</a>()
190      (<span class='d'>case-inf</span> <span class='d'>(f)</span>
191        <span class='d'>(() &#39;())</span>
192        <span class='d'>((f) (take n f))</span>
193        <span class='d'>((a) a)</span>
194        (<span class='d'>(a f)</span>
195         (<span class='d'>cons</span> <span class='d'>(car a)</span>
196           (<span class='d'>take</span> (<a id='13' tid='14' class='m'>and</a> <a id='15' tid='16' class='m'>n</a> (<a id='17' tid='18' class='m'>-</a> <a id='19' tid='20' class='m'>n</a> <a id='21' tid='22' class='m'>1</a>)) <span class='d'>f</span>)))))))
197
198 
199(<a id='291' tid='292' class='u'>define-syntax</a> <a id='293' tid='294' class='u'>exist</a>
200  (<a id='87' tid='88' class='m'>syntax-rules</a> ()
201    ((<a id='89' tid='90' class='m'>_</a> (<a id='91' tid='92' class='m'>x</a> <a id='93' tid='94' class='m'>...</a>) <a id='95' tid='96' class='m'>g0</a> <a id='97' tid='98' class='m'>g</a> <a id='99' tid='100' class='m'>...</a>)
202     (<span class='d'>lambdag@</span> <span class='d'>(s)</span>
203       (<span class='d'>inc</span>
204         (<span class='d'>let</span> ((<a id='101' tid='102' class='m'>x</a> (<a id='103' tid='104' class='m'>var</a> <a id='105' tid='106' class='m'>&#39;</a><a id='107' tid='108' class='m'>x</a>)) <a id='109' tid='110' class='m'>...</a>)
205           <span class='d'>(bind* (g0 s) g ...)</span>))))))
206 
207<span class='d'>(define-syntax bind*
208  (syntax-rules ()
209    ((_ e) e)
210    ((_ e g0 g ...) (bind* (bind e g0) g ...))))</span>
211 
212(<a id='181' tid='182' class='u'>define</a> <a id='183' tid='184' class='u'>bind</a>
213  <span class='d'>(lambda (a-inf g)
214    (case-inf a-inf
215      (() (mzero))
216      ((f) (inc (bind (f) g)))
217      ((a) (g a))
218      ((a f) (mplus (g a) (lambdaf@ () (bind (f) g))))))</span>)
219
220(<a id='233' tid='234' class='u'>define-syntax</a> <a id='235' tid='236' class='u'>conde</a>
221  (<a id='111' tid='112' class='m'>syntax-rules</a> ()
222    ((<a id='113' tid='114' class='m'>_</a> (<a id='115' tid='116' class='m'>g0</a> <a id='117' tid='118' class='m'>g</a> <a id='119' tid='120' class='m'>...</a>) (<a id='121' tid='122' class='m'>g1</a> <a id='123' tid='124' class='m'>g^</a> <a id='125' tid='126' class='m'>...</a>) <a id='127' tid='128' class='m'>...</a>)
223     <span class='d'>(lambdag@ (s) 
224       (inc 
225         (mplus* 
226           (bind* (g0 s) g ...)
227           (bind* (g1 s) g^ ...) ...)))</span>)))
228 
229<span class='d'>(define-syntax mplus*
230  (syntax-rules ()
231    ((_ e) e)
232    ((_ e0 e ...) (mplus e0 
233                    (lambdaf@ () (mplus* e ...))))))</span>
234 
235<span class='d'>(define mplus
236  (lambda (a-inf f)
237    (case-inf a-inf
238      (() (f))
239      ((f^) (inc (mplus (f) f^)))
240      ((a) (choice a f))
241      ((a f^) (choice a (lambdaf@ () (mplus (f) f^)))))))</span>
242
243(<a id='185' tid='186' class='u'>define-syntax</a> <a id='187' tid='188' class='u'>conda</a>
244  (<a id='189' tid='190' class='u'>syntax-rules</a> ()
245    ((<a id='191' tid='192' class='u'>_</a> (<a id='193' tid='194' class='u'>g0</a> <a id='195' tid='196' class='u'>g</a> <a id='197' tid='198' class='u'>...</a>) (<a id='199' tid='200' class='u'>g1</a> <a id='201' tid='202' class='u'>g^</a> <a id='203' tid='204' class='u'>...</a>) <a id='205' tid='206' class='u'>...</a>)
246     (<a id='207' tid='208' class='u'>lambdag@</a> (<a id='209' tid='210' class='u'>s</a>)
247       (<a id='211' tid='212' class='u'>inc</a>
248         (<a id='213' tid='214' class='u'>ifa</a> ((<a id='215' tid='216' class='u'>g0</a> <a id='217' tid='218' class='u'>s</a>) <a id='219' tid='220' class='u'>g</a> <a id='221' tid='222' class='u'>...</a>)
249              ((<a id='223' tid='224' class='u'>g1</a> <a id='225' tid='226' class='u'>s</a>) <a id='227' tid='228' class='u'>g^</a> <a id='229' tid='230' class='u'>...</a>) <a id='231' tid='232' class='u'>...</a>))))))
250 
251(<a id='361' tid='362' class='u'>define-syntax</a> <a id='363' tid='364' class='u'>ifa</a>
252  (<span class='d'>syntax-rules</span> <span class='d'>()</span>
253    <span class='d'>((_) (mzero))</span>
254    ((<a id='129' tid='130' class='m'>_</a> (<a id='131' tid='132' class='m'>e</a> <a id='133' tid='134' class='m'>g</a> <a id='135' tid='136' class='m'>...</a>) <a id='137' tid='138' class='m'>b</a> <a id='139' tid='140' class='m'>...</a>)
255     <span class='d'>(let loop ((a-inf e))
256       (case-inf a-inf
257         (() (ifa b ...))
258         ((f) (inc (loop (f))))
259         ((a) (bind* a-inf g ...))
260         ((a f) (bind* a-inf g ...))))</span>)))
261
262(<a id='237' tid='238' class='u'>define-syntax</a> <a id='239' tid='240' class='u'>condu</a>
263  (<a id='241' tid='242' class='u'>syntax-rules</a> ()
264    ((<a id='243' tid='244' class='u'>_</a> (<a id='245' tid='246' class='u'>g0</a> <a id='247' tid='248' class='u'>g</a> <a id='249' tid='250' class='u'>...</a>) (<a id='251' tid='252' class='u'>g1</a> <a id='253' tid='254' class='u'>g^</a> <a id='255' tid='256' class='u'>...</a>) <a id='257' tid='258' class='u'>...</a>)
265     (<a id='259' tid='260' class='u'>lambdag@</a> (<a id='261' tid='262' class='u'>s</a>)
266       (<a id='263' tid='264' class='u'>inc</a>
267         (<a id='265' tid='266' class='u'>ifu</a> ((<a id='267' tid='268' class='u'>g0</a> <a id='269' tid='270' class='u'>s</a>) <a id='271' tid='272' class='u'>g</a> <a id='273' tid='274' class='u'>...</a>)
268              ((<a id='275' tid='276' class='u'>g1</a> <a id='277' tid='278' class='u'>s</a>) <a id='279' tid='280' class='u'>g^</a> <a id='281' tid='282' class='u'>...</a>) <a id='283' tid='284' class='u'>...</a>))))))
269 
270(<a id='365' tid='366' class='u'>define-syntax</a> <a id='367' tid='368' class='u'>ifu</a>
271  (<span class='d'>syntax-rules</span> <span class='d'>()</span>
272    <span class='d'>((_) (mzero))</span>
273    ((<a id='141' tid='142' class='m'>_</a> (<a id='143' tid='144' class='m'>e</a> <a id='145' tid='146' class='m'>g</a> <a id='147' tid='148' class='m'>...</a>) <a id='149' tid='150' class='m'>b</a> <a id='151' tid='152' class='m'>...</a>)
274     <span class='d'>(let loop ((a-inf e))
275       (case-inf a-inf
276         (() (ifu b ...))
277         ((f) (inc (loop (f))))
278         ((a) (bind* a-inf g ...))
279         ((a f) (bind* (unit a) g ...))))</span>)))
280
281(<a id='469' tid='470' class='u'>define-syntax</a> <a id='471' tid='472' class='u'>project</a>
282  (<a id='153' tid='154' class='m'>syntax-rules</a> ()
283    ((<a id='155' tid='156' class='m'>_</a> (<a id='157' tid='158' class='m'>x</a> <a id='159' tid='160' class='m'>...</a>) <a id='161' tid='162' class='m'>g</a> <a id='163' tid='164' class='m'>g*</a> <a id='165' tid='166' class='m'>...</a>)
284     (<span class='d'>lambdag@</span> <span class='d'>(s)</span>
285       (<span class='d'>let</span> ((<a id='167' tid='168' class='m'>x</a> (<a id='169' tid='170' class='m'>walk*</a> <a id='171' tid='172' class='m'>x</a> <a id='173' tid='174' class='m'>s</a>)) <a id='175' tid='176' class='m'>...</a>)
286         <span class='d'>((exist () g g* ...) s)</span>)))))
287
288(<a id='583' tid='584' class='u'>define</a> <a id='585' tid='586' class='u'>succeed</a> <span class='d'>(== #f #f)</span>)
289
290(<a id='357' tid='358' class='u'>define</a> <a id='359' tid='360' class='u'>fail</a> <span class='d'>(== #f #t)</span>)
291
292<span class='d'>(define onceo
293  (lambda (g)
294    (condu
295      (g succeed)
296      (else fail))))</span>
297
298
299</pre>
300</div>
301<div id="right" class="src">
302<pre>
303<a id='rightstart' tid='leftstart'></a>
304<a id='842' tid='841' class='u'>;;; This file was generated by writeminikanren.pl
305</a><a id='844' tid='843' class='u'>;;; Generated at 2007-10-25 15:24:42
306</a>
307<span class='i'>(define *debug-tags* &#39;())</span>
308<span class='i'>(define debug
309  (lambda (tags format . args)
310    (let* ((tags (if (not (pair? tags)) (list tags) tags))
311           (fs (string-append &quot;[&quot; (symbol-&gt;string (car tags)) &quot;] &quot; format &quot;\n&quot;)))
312      (cond
313       [(null? tags)]
314       [(pair? tags)
315        (if (member (car tags) *debug-tags*)
316            (apply printf fs args)
317            (void))]
318       ))))</span>
319
320
321<span class='i'>;; Stream primitives
322</span>(<a id='388' tid='387' class='u'>define-syntax</a> <a id='390' tid='389' class='u'>lambdag@</a>
323  <span class='i'>(syntax-rules ()
324    ((_ (p ...) e ...) (lambda (p ...) e ...)))</span>)
325
326(<a id='384' tid='383' class='u'>define-syntax</a> <a id='386' tid='385' class='u'>lambdaf@</a>
327  <span class='i'>(syntax-rules ()
328    ((_ () e ...) (lambda () e ...)))</span>)
329
330(<a id='370' tid='369' class='u'>define-syntax</a> <a id='372' tid='371' class='u'>inc</a>
331  (<a id='374' tid='373' class='u'>syntax-rules</a> () ((<a id='376' tid='375' class='u'>_</a> <a id='378' tid='377' class='u'>e</a>) (<a id='380' tid='379' class='u'>lambdaf@</a> () <a id='382' tid='381' class='u'>e</a>))))
332
333<span class='i'>(define defunc
334  (lambda (f)
335    (if (procedure? f) (defunc (f)) f)))</span>
336
337<span class='i'>(define snull &#39;snull)</span>
338
339<span class='i'>(define snull? 
340  (lambda (s)
341    (eq? s snull)))</span>
342
343<span class='i'>(define-syntax scons
344  (syntax-rules ()
345    ((_ a d) (cons a (lambda () d)))))</span>
346
347<span class='i'>(define scar
348  (lambda (s)
349    (cond
350     [(procedure? s) (scar (s))]
351     [else (car s)])))</span>
352
353<span class='i'>(define scdr
354  (lambda (s)
355    (cond
356     [(procedure? s) (scdr (s))]
357     [else ((cdr s))])))</span>
358
359<span class='i'>(define-syntax sunit
360  (syntax-rules ()
361    ((_ a) (scons a snull))))</span>
362
363<span class='i'>(define slift
364  (lambda (f)
365    (lambda args
366      (sunit (apply f args)))))</span>
367
368<span class='i'>(define-syntax make-stream
369  (syntax-rules ()
370    ((_) snull)
371    ((_ e1 e2 ...) (scons e1 (make-stream e2 ...)))))</span>
372
373(<a id='588' tid='587' class='u'>define</a> <a id='590' tid='589' class='u'>take</a>
374  (<span class='i'>lambda</span> <span class='i'>(n s)</span>
375    (<a id='2' tid='1' class='m'>if</a> (<a id='4' tid='3' class='m'>and</a> <a id='6' tid='5' class='m'>n</a> (<a id='8' tid='7' class='m'>zero?</a> <a id='10' tid='9' class='m'>n</a>))
376        <a id='12' tid='11' class='m'>&#39;</a>()
377        (<span class='i'>let</span> <span class='i'>([s (defunc s)])</span>
378          (<span class='i'>cond</span>
379           <span class='i'>[(snull? s) &#39;()]</span>
380           [<span class='i'>else</span> (<span class='i'>cons</span> <span class='i'>(scar s)</span> (<span class='i'>take</span> (<a id='14' tid='13' class='m'>and</a> <a id='16' tid='15' class='m'>n</a> (<a id='18' tid='17' class='m'>-</a> <a id='20' tid='19' class='m'>n</a> <a id='22' tid='21' class='m'>1</a>)) <span class='i'>(scdr s)</span>))])))))
381
382<span class='i'>(define smerge
383  (lambda (s1 s2)
384    (cond
385     [(snull? s1) s2]
386     [(procedure? s1)
387      (lambda () (smerge s2 (s1)))]
388     [else (scons (scar s1) (smerge s2 (scdr s1)))])))</span>
389
390<span class='i'>(define stream-merge
391  (lambda (ss)
392    (cond
393     [(snull? ss) snull]
394     [(procedure? ss) (lambda () (stream-merge (ss)))]
395     [(snull? (scar ss)) (stream-merge (scdr ss))]
396     [(procedure? (scar ss)) (lambda () 
397                               (smerge (stream-merge (scdr ss))
398                                       (scar ss)))]
399     [else (scons (scar (scar ss)) (smerge (scdr (scar ss))
400                                           (stream-merge (scdr ss))))])))</span>
401
402<span class='i'>(define smap
403  (lambda (f s)
404    (cond
405     [(snull? s) snull]
406     [(procedure? s) (lambda () (smap f (s)))]
407     [else (scons (f (scar s)) (smap f (scdr s)))])))</span>
408
409
410
411<span class='i'>;; Substitution
412</span>(<a id='528' tid='527' class='u'>define-syntax</a> <a id='530' tid='529' class='u'>rhs</a>
413  (<a id='532' tid='531' class='u'>syntax-rules</a> ()
414    ((<a id='534' tid='533' class='u'>_</a> <a id='536' tid='535' class='u'>x</a>) (<a id='538' tid='537' class='u'>cdr</a> <a id='540' tid='539' class='u'>x</a>))))
415
416(<a id='392' tid='391' class='u'>define-syntax</a> <a id='394' tid='393' class='u'>lhs</a>
417  (<a id='396' tid='395' class='u'>syntax-rules</a> ()
418    ((<a id='398' tid='397' class='u'>_</a> <a id='400' tid='399' class='u'>x</a>) (<a id='402' tid='401' class='u'>car</a> <a id='404' tid='403' class='u'>x</a>))))
419
420(<a id='570' tid='569' class='u'>define-syntax</a> <a id='572' tid='571' class='u'>size-s</a>
421  (<a id='574' tid='573' class='u'>syntax-rules</a> ()
422    ((<a id='576' tid='575' class='u'>_</a> <a id='578' tid='577' class='u'>x</a>) (<a id='580' tid='579' class='u'>length</a> <a id='582' tid='581' class='u'>x</a>))))
423
424(<a id='714' tid='713' class='u'>define-syntax</a> <a id='716' tid='715' class='u'>var</a>
425  (<a id='718' tid='717' class='u'>syntax-rules</a> ()
426    ((<a id='720' tid='719' class='u'>_</a> <a id='722' tid='721' class='u'>x</a>) (<a id='724' tid='723' class='u'>vector</a> <a id='726' tid='725' class='u'>x</a>))))
427
428(<a id='728' tid='727' class='u'>define-syntax</a> <a id='730' tid='729' class='u'>var?</a>
429  (<a id='732' tid='731' class='u'>syntax-rules</a> ()
430    ((<a id='734' tid='733' class='u'>_</a> <a id='736' tid='735' class='u'>x</a>) (<a id='738' tid='737' class='u'>vector?</a> <a id='740' tid='739' class='u'>x</a>))))
431
432(<a id='286' tid='285' class='u'>define</a> <a id='288' tid='287' class='u'>empty-s</a> <a id='290' tid='289' class='u'>&#39;</a>())
433
434(<a id='742' tid='741' class='u'>define</a> <a id='744' tid='743' class='u'>walk</a>
435  (<a id='746' tid='745' class='u'>lambda</a> (<a id='748' tid='747' class='u'>v</a> <a id='750' tid='749' class='u'>s</a>)
436    (<a id='752' tid='751' class='u'>cond</a>
437      ((<a id='754' tid='753' class='u'>var?</a> <a id='756' tid='755' class='u'>v</a>)
438       (<a id='758' tid='757' class='u'>let</a> ((<a id='760' tid='759' class='u'>a</a> (<a id='762' tid='761' class='u'>assq</a> <a id='764' tid='763' class='u'>v</a> <a id='766' tid='765' class='u'>s</a>)))
439         (<a id='768' tid='767' class='u'>cond</a>
440           (<a id='770' tid='769' class='u'>a</a> (<a id='772' tid='771' class='u'>walk</a> (<a id='774' tid='773' class='u'>rhs</a> <a id='776' tid='775' class='u'>a</a>) <a id='778' tid='777' class='u'>s</a>))
441           (<a id='780' tid='779' class='u'>else</a> <a id='782' tid='781' class='u'>v</a>))))
442      (<a id='784' tid='783' class='u'>else</a> <a id='786' tid='785' class='u'>v</a>))))
443
444(<a id='296' tid='295' class='u'>define</a> <a id='298' tid='297' class='u'>ext-s</a>
445  (<a id='300' tid='299' class='u'>lambda</a> (<a id='302' tid='301' class='u'>x</a> <a id='304' tid='303' class='u'>v</a> <a id='306' tid='305' class='u'>s</a>)
446    (<a id='308' tid='307' class='u'>cons</a> <a id='310' tid='309' class='u'>`</a>(<a id='312' tid='311' class='u'>,</a><a id='314' tid='313' class='u'>x</a> <a id='316' tid='315' class='u'>.</a> <a id='318' tid='317' class='u'>,</a><a id='320' tid='319' class='u'>v</a>) <a id='322' tid='321' class='u'>s</a>)))
447
448(<a id='592' tid='591' class='u'>define</a> <a id='594' tid='593' class='u'>unify</a>
449  <span class='i'>(lambda (v w s env)
450    ((env-unify env) v w s env))</span>)
451
452<span class='i'>(define unify-good
453  (lambda (v w s env)
454;    (printf &quot;[unify-good]: ~a &lt;--&gt; ~a :: ~a\n&quot; v w s)
455    (let ((v (walk v s))
456          (w (walk w s)))
457      (cond
458        ((eq? v w) s)
459        ((var? v) (ext-s v w s))
460        ((var? w) (ext-s w v s))
461        ((and (pair? v) (pair? w))
462         (let ((s (unify-good (car v) (car w) s env)))
463           (and s (unify-good (cdr v) (cdr w) s env))))
464        ((equal? v w) s)
465        (else #f)))))</span>
466
467
468<span class='i'>(define unify-evil
469  (lambda (v w s env)
470    (debug &#39;(unify-evil unify) 
471           &quot;v=~a, w=~a, cvars: ~a\n  subst:~a&quot; v w (env-cvars env) s)
472    (let ((vv (walk v s))
473          (ww (walk w s)))
474      (cond
475       ((eq? vv ww) s)
476       ((and (var? vv) (memq v (env-cvars env))) #f)
477       ((and (var? ww) (memq w (env-cvars env))) #f)
478       ((var? vv) (ext-s vv ww s))
479       ((var? ww) (ext-s ww vv s))
480       ((and (pair? vv) (pair? ww))
481        (let ((s (unify-evil (car vv) (car ww) s env)))
482          (and s (unify-evil (cdr vv) (cdr ww) s env))))
483       ((equal? vv ww) s)
484       (else #f)))))</span>
485
486
487<span class='i'>(define switch-unify
488  (lambda (env)
489    (if (eq? (env-unify env) unify-good)
490        (change-unify env unify-evil)
491        (change-unify env unify-good))))</span>
492
493<span class='i'>(define unify-pred
494  (lambda (v pred s env)
495    (let ((v (walk v s)))
496      (if (var? v)
497          (cond 
498           [(eq? pred number?) (ext-s v (random 9999999999) s)]
499           [(eq? pred string?) (ext-s v &quot;random string...&quot; s)]
500           [(eq? pred symbol?) (ext-s v &#39;randomstring... s)]
501           )
502          (cond
503           [(pred v) s]
504           [else #f])))))</span>
505
506<span class='i'>(define predo
507  (lambda (q pred)
508    (lambdag@ (s env)
509      (let ((s1 (unify-pred q pred s env)))
510        (cond
511         [(not s1) snull]
512         [else (sunit s1)])))))</span>
513
514(<a id='596' tid='595' class='u'>define</a> <a id='598' tid='597' class='u'>unify-check</a>
515  (<a id='600' tid='599' class='u'>lambda</a> (<a id='602' tid='601' class='u'>u</a> <a id='604' tid='603' class='u'>v</a> <a id='606' tid='605' class='u'>s</a>)
516    (<a id='608' tid='607' class='u'>let</a> ((<a id='610' tid='609' class='u'>u</a> (<a id='612' tid='611' class='u'>walk</a> <a id='614' tid='613' class='u'>u</a> <a id='616' tid='615' class='u'>s</a>))
517          (<a id='618' tid='617' class='u'>v</a> (<a id='620' tid='619' class='u'>walk</a> <a id='622' tid='621' class='u'>v</a> <a id='624' tid='623' class='u'>s</a>)))
518      (<a id='626' tid='625' class='u'>cond</a>
519        ((<a id='628' tid='627' class='u'>eq?</a> <a id='630' tid='629' class='u'>u</a> <a id='632' tid='631' class='u'>v</a>) <a id='634' tid='633' class='u'>s</a>)
520        ((<a id='636' tid='635' class='u'>var?</a> <a id='638' tid='637' class='u'>u</a>) (<a id='640' tid='639' class='u'>ext-s-check</a> <a id='642' tid='641' class='u'>u</a> <a id='644' tid='643' class='u'>v</a> <a id='646' tid='645' class='u'>s</a>))
521        ((<a id='648' tid='647' class='u'>var?</a> <a id='650' tid='649' class='u'>v</a>) (<a id='652' tid='651' class='u'>ext-s-check</a> <a id='654' tid='653' class='u'>v</a> <a id='656' tid='655' class='u'>u</a> <a id='658' tid='657' class='u'>s</a>))
522        ((<a id='660' tid='659' class='u'>and</a> (<a id='662' tid='661' class='u'>pair?</a> <a id='664' tid='663' class='u'>u</a>) (<a id='666' tid='665' class='u'>pair?</a> <a id='668' tid='667' class='u'>v</a>))
523         (<a id='670' tid='669' class='u'>let</a> ((<a id='672' tid='671' class='u'>s</a> (<a id='674' tid='673' class='u'>unify-check</a> (<a id='676' tid='675' class='u'>car</a> <a id='678' tid='677' class='u'>u</a>) (<a id='680' tid='679' class='u'>car</a> <a id='682' tid='681' class='u'>v</a>) <a id='684' tid='683' class='u'>s</a>)))
524           (<a id='686' tid='685' class='u'>and</a> <a id='688' tid='687' class='u'>s</a> (<a id='690' tid='689' class='u'>unify-check</a> (<a id='692' tid='691' class='u'>cdr</a> <a id='694' tid='693' class='u'>u</a>) (<a id='696' tid='695' class='u'>cdr</a> <a id='698' tid='697' class='u'>v</a>) <a id='700' tid='699' class='u'>s</a>))))
525        ((<a id='702' tid='701' class='u'>equal?</a> <a id='704' tid='703' class='u'>u</a> <a id='706' tid='705' class='u'>v</a>) <a id='708' tid='707' class='u'>s</a>)
526        (<a id='710' tid='709' class='u'>else</a> <a id='712' tid='711' class='u'>#f</a>)))))
527
528 
529(<a id='324' tid='323' class='u'>define</a> <a id='326' tid='325' class='u'>ext-s-check</a>
530  (<a id='328' tid='327' class='u'>lambda</a> (<a id='330' tid='329' class='u'>x</a> <a id='332' tid='331' class='u'>v</a> <a id='334' tid='333' class='u'>s</a>)
531    (<a id='336' tid='335' class='u'>cond</a>
532      ((<a id='338' tid='337' class='u'>occurs-check</a> <a id='340' tid='339' class='u'>x</a> <a id='342' tid='341' class='u'>v</a> <a id='344' tid='343' class='u'>s</a>) <a id='346' tid='345' class='u'>#f</a>)
533      (<a id='348' tid='347' class='u'>else</a> (<a id='350' tid='349' class='u'>ext-s</a> <a id='352' tid='351' class='u'>x</a> <a id='354' tid='353' class='u'>v</a> <a id='356' tid='355' class='u'>s</a>)))))
534
535(<a id='406' tid='405' class='u'>define</a> <a id='408' tid='407' class='u'>occurs-check</a>
536  (<a id='410' tid='409' class='u'>lambda</a> (<a id='412' tid='411' class='u'>x</a> <a id='414' tid='413' class='u'>v</a> <a id='416' tid='415' class='u'>s</a>)
537    (<a id='418' tid='417' class='u'>let</a> ((<a id='420' tid='419' class='u'>v</a> (<a id='422' tid='421' class='u'>walk</a> <a id='424' tid='423' class='u'>v</a> <a id='426' tid='425' class='u'>s</a>)))
538      (<a id='428' tid='427' class='u'>cond</a>
539        ((<a id='430' tid='429' class='u'>var?</a> <a id='432' tid='431' class='u'>v</a>) (<a id='434' tid='433' class='u'>eq?</a> <a id='436' tid='435' class='u'>v</a> <a id='438' tid='437' class='u'>x</a>))
540        ((<a id='440' tid='439' class='u'>pair?</a> <a id='442' tid='441' class='u'>v</a>) 
541         (<a id='444' tid='443' class='u'>or</a> 
542           (<a id='446' tid='445' class='u'>occurs-check</a> <a id='448' tid='447' class='u'>x</a> (<a id='450' tid='449' class='u'>car</a> <a id='452' tid='451' class='u'>v</a>) <a id='454' tid='453' class='u'>s</a>)
543           (<a id='456' tid='455' class='u'>occurs-check</a> <a id='458' tid='457' class='u'>x</a> (<a id='460' tid='459' class='u'>cdr</a> <a id='462' tid='461' class='u'>v</a>) <a id='464' tid='463' class='u'>s</a>)))
544        (<a id='466' tid='465' class='u'>else</a> <a id='468' tid='467' class='u'>#f</a>)))))
545
546(<a id='788' tid='787' class='u'>define</a> <a id='790' tid='789' class='u'>walk*</a>
547  (<a id='792' tid='791' class='u'>lambda</a> (<a id='794' tid='793' class='u'>w</a> <a id='796' tid='795' class='u'>s</a>)
548    (<a id='798' tid='797' class='u'>let</a> ((<a id='800' tid='799' class='u'>v</a> (<a id='802' tid='801' class='u'>walk</a> <a id='804' tid='803' class='u'>w</a> <a id='806' tid='805' class='u'>s</a>)))
549      (<a id='808' tid='807' class='u'>cond</a>
550        ((<a id='810' tid='809' class='u'>var?</a> <a id='812' tid='811' class='u'>v</a>) <a id='814' tid='813' class='u'>v</a>)
551        ((<a id='816' tid='815' class='u'>pair?</a> <a id='818' tid='817' class='u'>v</a>)
552         (<a id='820' tid='819' class='u'>cons</a>
553           (<a id='822' tid='821' class='u'>walk*</a> (<a id='824' tid='823' class='u'>car</a> <a id='826' tid='825' class='u'>v</a>) <a id='828' tid='827' class='u'>s</a>)
554           (<a id='830' tid='829' class='u'>walk*</a> (<a id='832' tid='831' class='u'>cdr</a> <a id='834' tid='833' class='u'>v</a>) <a id='836' tid='835' class='u'>s</a>)))
555        (<a id='838' tid='837' class='u'>else</a> <a id='840' tid='839' class='u'>v</a>)))))
556
557(<a id='524' tid='523' class='u'>define</a> <a id='526' tid='525' class='u'>reify-s</a>
558  (<span class='i'>lambda</span> <span class='i'>(v s)</span>
559    <span class='i'>(debug &#39;reify-s &quot;v: ~a\ns:~a&quot; v s)</span>
560    (<a id='38' tid='37' class='m'>let</a> ((<a id='40' tid='39' class='m'>v</a> (<a id='42' tid='41' class='m'>walk</a> <a id='44' tid='43' class='m'>v</a> <a id='46' tid='45' class='m'>s</a>)))
561      (<a id='48' tid='47' class='m'>cond</a>
562        ((<a id='50' tid='49' class='m'>var?</a> <a id='52' tid='51' class='m'>v</a>)
563         (<a id='54' tid='53' class='m'>ext-s</a> <a id='56' tid='55' class='m'>v</a> (<a id='58' tid='57' class='m'>reify-name</a> (<a id='60' tid='59' class='m'>size-s</a> <a id='62' tid='61' class='m'>s</a>)) <a id='64' tid='63' class='m'>s</a>))
564        ((<a id='66' tid='65' class='m'>pair?</a> <a id='68' tid='67' class='m'>v</a>) (<a id='70' tid='69' class='m'>reify-s</a> (<a id='72' tid='71' class='m'>cdr</a> <a id='74' tid='73' class='m'>v</a>)
565                     (<a id='76' tid='75' class='m'>reify-s</a> (<a id='78' tid='77' class='m'>car</a> <a id='80' tid='79' class='m'>v</a>) <a id='82' tid='81' class='m'>s</a>)))
566        (<a id='84' tid='83' class='m'>else</a> <a id='86' tid='85' class='m'>s</a>)))))
567
568(<a id='504' tid='503' class='u'>define</a> <a id='506' tid='505' class='u'>reify-name</a>
569  (<a id='508' tid='507' class='u'>lambda</a> (<a id='510' tid='509' class='u'>n</a>)
570    (<a id='512' tid='511' class='u'>string-&gt;symbol</a>
571      (<a id='514' tid='513' class='u'>string-append</a> <a id='516' tid='515' class='u'>&quot;_&quot;</a> <a id='518' tid='517' class='u'>&quot;.&quot;</a> (<a id='520' tid='519' class='u'>number-&gt;string</a> <a id='522' tid='521' class='u'>n</a>)))))
572
573(<a id='474' tid='473' class='u'>define</a> <a id='476' tid='475' class='u'>reify</a>
574  (<a id='478' tid='477' class='u'>lambda</a> (<a id='480' tid='479' class='u'>v</a> <a id='482' tid='481' class='u'>s</a>)
575    (<a id='484' tid='483' class='u'>let</a> ((<a id='486' tid='485' class='u'>v</a> (<a id='488' tid='487' class='u'>walk*</a> <a id='490' tid='489' class='u'>v</a> <a id='492' tid='491' class='u'>s</a>)))
576      (<a id='494' tid='493' class='u'>walk*</a> <a id='496' tid='495' class='u'>v</a> (<a id='498' tid='497' class='u'>reify-s</a> <a id='500' tid='499' class='u'>v</a> <a id='502' tid='501' class='u'>empty-s</a>)))))
577
578
579<span class='i'>(define pkg
580  (lambda (s c)
581    (list s c)))</span>
582<span class='i'>(define pkg-subst car)</span>                  <span class='i'>; current substitution
583</span><span class='i'>(define pkg-constraints cadr)</span>
584<span class='i'>(define ext-pkg-constraints
585  (lambda (p cs ctexts env)
586    (let ([newc (map (lambda (g t) 
587                       (make-constraint g (env-vars env) t))
588                     cs ctexts)])
589      (pkg (pkg-subst p) (append newc (pkg-constraints p))))))</span>
590
591<span class='i'>;; constraints save the current environment vars
592</span><span class='i'>(define make-constraint
593  (lambda (g vars text)
594    (list g vars text)))</span>
595<span class='i'>(define constraint-goal car)</span>            <span class='i'>; constraint goal
596</span><span class='i'>(define constraint-vars cadr)</span>            <span class='i'>; variables which the constraint care about
597</span><span class='i'>(define constraint-text caddr)</span>
598
599<span class='i'>;; environment
600</span><span class='i'>(define make-env
601  (lambda (unify constraints vars cvars)
602    (list unify constraints vars cvars)))</span>
603<span class='i'>(define empty-env (list unify-good &#39;() &#39;() &#39;()))</span>
604<span class='i'>(define env-unify car)</span>                 <span class='i'>; which unification to use (env)
605</span><span class='i'>(define env-constraints cadr)</span>          <span class='i'>; current constraints (env)
606</span><span class='i'>(define env-vars caddr)</span>                <span class='i'>; variables at this point (env)
607</span><span class='i'>(define env-cvars cadddr)</span>              <span class='i'>; checked variables at this point (env)
608</span><span class='i'>(define env-constraint-goals
609  (lambda (p)
610    (map constraint-goal (env-constraint p))))</span>
611
612
613
614<span class='i'>(define change-unify
615  (lambda (p u)
616    (make-env u (env-constraints p) (env-vars p) (env-cvars p))))</span>
617
618<span class='i'>(define change-constraints
619  (lambda (p c)
620    (make-env (env-unify p) c (env-vars p) (env-cvars p))))</span>
621
622<span class='i'>(define change-vars
623  (lambda (p v)
624    (make-env (env-unify p) (env-constraints p) v (env-cvars p))))</span>
625
626<span class='i'>(define change-cvars
627  (lambda (p cv)
628    (env (env-unify p) (env-constraints p) (env-vars p) cv)))</span>
629
630<span class='i'>(define ext-constraint
631  (lambda (env new-cg)
632    (let ([newc (map (lambda (g) (make-constraint g (env-vars env) &#39;a))
633                     new-cg)])
634      (change-constraints env newc))))</span>
635
636<span class='i'>(define ext-vars
637  (lambda (env new-vars)
638    (change-vars env (append new-vars (env-vars env)))))</span>
639
640<span class='i'>(define ext-cvars
641  (lambda (env new-cvars)
642    (change-cvars env (append new-cvars (env-cvars env)))))</span>
643
644
645
646<span class='i'>;;; miniKanren
647</span>
648(<a id='182' tid='181' class='u'>define</a> <a id='184' tid='183' class='u'>bind</a>
649  <span class='i'>(lambda (s f env)
650    (cond
651     [(procedure? s) (lambda () (bind (s) f env))]
652     [else
653      (stream-merge (smap (lambda (s) (f s env)) s))]))</span>)
654
655<span class='i'>(define bind*
656  (lambda (s goals env)
657    (cond
658     [(null? goals)
659      (stream-merge
660       (smap (lambda (s) 
661               (bind-constraints (sunit s) (pkg-constraints s) env))
662             s))]
663     [(snull? s) snull]
664     [else (bind* (bind s (car goals) env) (cdr goals) env)])))</span>
665
666<span class='i'>(define bind*
667  (lambda (s goals env)
668    (cond
669     [(null? goals) s]
670     [(snull? s) snull]
671     [else (bind* (bind s (car goals) env) (cdr goals) env)])))</span>
672
673<span class='i'>(define bind-constraints
674  (lambda (s cs env)
675    (cond
676     [(null? cs) s]
677     [(snull? s) snull]
678     [else 
679      (debug &#39;bind-constraints
680             &quot;checking constraint: ~a&quot; (constraint-text (car cs)))
681      (bind-constraints
682            (bind s
683                  (constraint-goal (car cs))
684                  (make-env (env-unify env)
685                            &#39;()                     ; no constraints
686                            (env-vars env)
687                            (constraint-vars (car cs)))) 
688            (cdr cs)
689            env)])))</span>
690
691(<a id='178' tid='177' class='u'>define</a> <a id='180' tid='179' class='u'>==</a>
692  <span class='i'>(lambda (u v)
693    (lambdag@ (s env)
694      (let ((s1 ((env-unify env) u v (pkg-subst s) env)))
695        (cond
696         [(not s1) snull]
697         [else (sunit (pkg s1 (pkg-constraints s)))]))))</span>)
698
699<span class='i'>(define ==
700  (lambda (u v)
701    (lambdag@ (s env)
702      (let ((s1 ((env-unify env) u v (pkg-subst s) env)))
703        (cond
704         [(not s1) snull]
705         [else
706          (let ([cc (bind-constraints (sunit (pkg s1 &#39;()))
707                                      (pkg-constraints s) env)])
708            (if (snull? cc)
709                snull
710                (sunit (pkg s1 (filter (lambda (c) 
711                                         (not (tautology? c (pkg-subst s))))
712                                       (pkg-constraints s))))))])))))</span>
713
714<span class='i'>(define ando
715  (lambda goals
716    (lambdag@ (s env)
717      (bind* (sunit s) goals env))))</span>
718
719<span class='i'>(define org2
720  (lambda (goals)
721    (lambdag@ (s env)
722      (cond
723       [(null? goals) snull]
724       [else
725        (scons (bind (sunit s) (car goals) env)
726               ((org2 (cdr goals)) s env))]))))</span>
727
728<span class='i'>(define oro
729  (lambda goals
730    (lambdag@ (s env)
731      (stream-merge ((org2 goals) s env)))))</span>
732
733<span class='i'>(define noto
734  (lambda (g)
735    (lambdag@ (s env)
736      (inc
737        (let ([ans (g s (switch-unify env))])
738          (letrec ((negate (lambda (s)
739                             (cond
740                              [(procedure? s) (lambda () (negate (s)))]
741                              [(snull? ans) (succeed s env)]
742                              [else (fail s env)]))))
743                  (negate ans)))))))</span>
744
745<span class='i'>(define noto
746  (lambda (g)
747    (lambdag@ (s env)
748      (let ([ans (defunc (g s (switch-unify env)))])
749        ((if (snull? ans)
750             ;;             (begin (printf &quot;###fail###\n&quot;) succeed)
751             ;;             (begin (printf &quot;###succeed###\n&quot;) fail)
752             succeed
753             fail
754             ) s env)))))</span>
755
756
757(<a id='292' tid='291' class='u'>define-syntax</a> <a id='294' tid='293' class='u'>exist</a>
758  (<a id='88' tid='87' class='m'>syntax-rules</a> ()
759    ((<a id='90' tid='89' class='m'>_</a> (<a id='92' tid='91' class='m'>x</a> <a id='94' tid='93' class='m'>...</a>) <a id='96' tid='95' class='m'>g0</a> <a id='98' tid='97' class='m'>g</a> <a id='100' tid='99' class='m'>...</a>)
760     (<span class='i'>lambdag@</span> <span class='i'>(s env)</span>
761       (<span class='i'>inc</span>
762         (<span class='i'>let</span> ((<a id='102' tid='101' class='m'>x</a> (<a id='104' tid='103' class='m'>var</a> <a id='106' tid='105' class='m'>&#39;</a><a id='108' tid='107' class='m'>x</a>)) <a id='110' tid='109' class='m'>...</a>)
763           <span class='i'>((ando g0 g ...) s (ext-vars env (list x ...)))</span>))))))
764
765<span class='i'>(define-syntax forall
766  (syntax-rules ()
767    ((_ (x ...) g0 g ...)
768     (lambdag@ (s env)
769       (inc
770         (let ((x (var &#39;x)) ...)
771           ((ando g0 g ...)
772            (let loop ([ss (pkg-subst s)] [vars (list x ...)])
773             (cond
774              [(null? vars) ss]
775              [else (loop (ext-s (car vars) (gensym) ss) (cdr vars))]))
776            (ext-vars env (list x ...)))))))))</span>
777
778(<a id='234' tid='233' class='u'>define-syntax</a> <a id='236' tid='235' class='u'>conde</a>
779  (<a id='112' tid='111' class='m'>syntax-rules</a> ()
780    ((<a id='114' tid='113' class='m'>_</a> (<a id='116' tid='115' class='m'>g0</a> <a id='118' tid='117' class='m'>g</a> <a id='120' tid='119' class='m'>...</a>) (<a id='122' tid='121' class='m'>g1</a> <a id='124' tid='123' class='m'>g^</a> <a id='126' tid='125' class='m'>...</a>) <a id='128' tid='127' class='m'>...</a>)
781     <span class='i'>(lambdag@ (s env)
782       (inc
783         ((oro (ando g0 g ...)
784               (ando g1 g^ ...) ...) s env)))</span>)))
785
786<span class='i'>(define-syntax condc
787  (syntax-rules ()
788    ((_ (g0 g ...)) (ando g0 g ...))
789    ((_ (g0 g ...) g^ ...)
790     (lambdag@ (s env)
791       (inc
792         ((oro (ando g0 g ...)
793               (assert ((noto g0))
794                       (condc g^ ...))) s env))))))</span>
795
796<span class='i'>(define reify-constraint
797  (lambda (s)
798    (lambda (c)
799      (let ((ct (constraint-text c)))
800        (cond
801         [(pair? ct)
802          (cons (car ct) 
803                (map (lambda (v) (walk* v (pkg-subst s))) (cdr ct)))]
804         [else ct])))))</span>
805
806<span class='i'>(define format-constraints
807  (lambda (s)
808    (debug &#39;format-constraints &quot;subst: ~a\nconstraints: ~a\n&quot; 
809           (pkg-subst s)
810           (pkg-constraints s))
811    (map (reify-constraint s)
812         (filter (lambda (c) 
813                   (not (tautology? c (pkg-subst s))))
814                 (pkg-constraints s)))))</span>
815
816
817(<a id='542' tid='541' class='u'>define-syntax</a> <a id='544' tid='543' class='u'>run</a>
818  (<a id='24' tid='23' class='m'>syntax-rules</a> ()
819    ((<a id='26' tid='25' class='m'>_</a> <a id='28' tid='27' class='m'>n</a> (<a id='30' tid='29' class='m'>x</a>) <a id='32' tid='31' class='m'>g0</a> <a id='34' tid='33' class='m'>g</a> <a id='36' tid='35' class='m'>...</a>)
820     <span class='i'>(let ((x (var &#39;x)))
821       (let ([ss ((ando g0 g ...) (pkg empty-s &#39;())
822                   (make-env unify-good &#39;() (list x) &#39;()))])
823         (take n (smap (lambda (s)
824

Large files files are truncated, but you can click here to view the full file