fork download
copy 
  1. (define amb-fail '*)
  2.  
  3. (define initialize-amb-fail
  4.   (lambda ()
  5.     (set! amb-fail
  6.       (lambda ()
  7.         (error "amb tree exhausted")))))
  8.  
  9. (initialize-amb-fail)
  10.  
  11. (define-macro amb
  12.   (lambda alts...
  13.     `(let ((+prev-amb-fail amb-fail))
  14.        (call/cc
  15.         (lambda (+sk)
  16.  
  17.           ,@(map (lambda (alt)
  18.                    `(call/cc
  19.                      (lambda (+fk)
  20.                        (set! amb-fail
  21.                          (lambda ()
  22.                            (set! amb-fail +prev-amb-fail)
  23.                            (+fk 'fail)))
  24.                        (+sk ,alt))))
  25.                  alts...)
  26.  
  27.           (+prev-amb-fail))))))
  28.  
  29. (define assert
  30.   (lambda (pred)
  31.     (if (not pred) (amb))))
  32.  
  33. (define solve-kalotan-puzzle
  34.   (lambda ()
  35.     (let ((parent1 (amb 'm 'f))
  36.           (parent2 (amb 'm 'f))
  37.           (kibi (amb 'm 'f))
  38.           (kibi-self-desc (amb 'm 'f))
  39.           (kibi-lied? (amb #t #f)))
  40.       (assert
  41.        (distinct? (list parent1 parent2)))
  42.       (assert
  43.        (if (eqv? kibi 'm)
  44.            (not kibi-lied?)))
  45.       (assert
  46.        (if kibi-lied?
  47.            (xor
  48.             (and (eqv? kibi-self-desc 'm)
  49.                  (eqv? kibi 'f))
  50.             (and (eqv? kibi-self-desc 'f)
  51.                  (eqv? kibi 'm)))))
  52.       (assert
  53.        (if (not kibi-lied?)
  54.            (xor
  55.             (and (eqv? kibi-self-desc 'm)
  56.                  (eqv? kibi 'm))
  57.             (and (eqv? kibi-self-desc 'f)
  58.                  (eqv? kibi 'f)))))
  59.       (assert
  60.        (if (eqv? parent1 'm)
  61.            (and
  62.             (eqv? kibi-self-desc 'm)
  63.             (xor
  64.              (and (eqv? kibi 'f)
  65.                   (eqv? kibi-lied? #f))
  66.              (and (eqv? kibi 'm)
  67.                   (eqv? kibi-lied? #t))))))
  68.       (assert
  69.        (if (eqv? parent1 'f)
  70.            (and
  71.             (eqv? kibi 'f)
  72.             (eqv? kibi-lied? #t))))
  73.       (list parent1 parent2 kibi))))
  74.  
  75.  
  76. (define distinct?
  77.   (lambda (xs)
  78.     (if (null? xs)
  79.         #t
  80.         (and (not (memv (car xs) (cdr xs)))
  81.              (distinct? (cdr xs))))))
  82.  
  83. (define xor 
  84.   (lambda (b1 b2)
  85.     (or (and b1 (not b2))
  86.         (and (not b1) b2))))
  87.  
  88. (display (solve-kalotan-puzzle))
  89. (display (amb))
  90.  
Runtime error #stdin #stdout #stderr 0.12s 11088KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(f m f)
stderr
copy 
Backtrace:
In ice-9/boot-9.scm:
 160: 11 [catch #t #<catch-closure 55b22310e260> ...]
In unknown file:
   ?: 10 [apply-smob/1 #<catch-closure 55b22310e260>]
In ice-9/boot-9.scm:
  66: 9 [call-with-prompt prompt0 ...]
In ice-9/eval.scm:
 432: 8 [eval # #]
In ice-9/boot-9.scm:
2404: 7 [save-module-excursion #<procedure 55b223130940 at ice-9/boot-9.scm:4051:3 ()>]
4058: 6 [#<procedure 55b223130940 at ice-9/boot-9.scm:4051:3 ()>]
1727: 5 [%start-stack load-stack ...]
1732: 4 [#<procedure 55b223145c60 ()>]
In unknown file:
   ?: 3 [primitive-load "/home/Etktye/prog.scm"]
In ice-9/eval.scm:
 387: 2 [eval # ()]
 411: 1 [eval # #]
In unknown file:
   ?: 0 [scm-error misc-error #f "~A" ("amb tree exhausted") #f]

ERROR: In procedure scm-error:
ERROR: amb tree exhausted
https://ideone.com/1LnWfH
language:
Scheme (guile 2.2.4)
created:
5 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!