Compare commits
3 Commits
57a84b372d
...
loops/hask
| Author | SHA1 | Date | |
|---|---|---|---|
| 4510e7e475 | |||
| aa620b767f | |||
| 23afc9dde3 |
@@ -528,183 +528,6 @@ let () =
|
||||
| [Rational (_, d)] -> Integer d
|
||||
| [Integer _] -> Integer 1
|
||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
||||
(* printf-spec: apply one Tcl/printf format spec to one arg.
|
||||
spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
|
||||
and ends with the conversion char. Supports d i u x X o c s f e g.
|
||||
Coerces arg to the right type per conversion. *)
|
||||
register "printf-spec" (fun args ->
|
||||
let spec_str, arg = match args with
|
||||
| [String s; v] -> (s, v)
|
||||
| _ -> raise (Eval_error "printf-spec: (spec arg)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let to_int v = match v with
|
||||
| Integer i -> i
|
||||
| Number f -> int_of_float f
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try int_of_string s
|
||||
with _ ->
|
||||
try int_of_float (float_of_string s)
|
||||
with _ -> 0)
|
||||
| Bool true -> 1 | Bool false -> 0
|
||||
| _ -> 0
|
||||
in
|
||||
let to_float v = match v with
|
||||
| Number f -> f
|
||||
| Integer i -> float_of_int i
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try float_of_string s with _ -> 0.0)
|
||||
| _ -> 0.0
|
||||
in
|
||||
let to_string v = match v with
|
||||
| String s -> s
|
||||
| Integer i -> string_of_int i
|
||||
| Number f -> Sx_types.format_number f
|
||||
| Bool true -> "1" | Bool false -> "0"
|
||||
| Nil -> ""
|
||||
| _ -> Sx_types.inspect v
|
||||
in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%d" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'u' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%u" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'x' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%x" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'X' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%X" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'o' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%o" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'c' ->
|
||||
let n_val = to_int arg in
|
||||
let body = String.sub spec_str 0 (n - 1) in
|
||||
let fmt = Scanf.format_from_string (body ^ "s") "%s" in
|
||||
String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
|
||||
| 's' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%s" in
|
||||
String (Printf.sprintf fmt (to_string arg))
|
||||
| 'f' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%f" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'e' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%e" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'E' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%E" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'g' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%g" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'G' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%G" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
|
||||
|
||||
(* scan-spec: apply one Tcl/scanf format spec to a string.
|
||||
Returns (consumed-count . parsed-value), or nil on failure. *)
|
||||
register "scan-spec" (fun args ->
|
||||
let spec_str, str = match args with
|
||||
| [String s; String input] -> (s, input)
|
||||
| _ -> raise (Eval_error "scan-spec: (spec input)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let len = String.length str in
|
||||
(* skip leading whitespace for non-%c/%s conversions *)
|
||||
let i = ref 0 in
|
||||
if type_char <> 'c' then
|
||||
while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
|
||||
let start = !i in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
|
||||
if !j > start && (str.[start] >= '0' && str.[start] <= '9'
|
||||
|| (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
|
||||
let n_val = int_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'x' | 'X' ->
|
||||
let j = ref !i in
|
||||
while !j < len &&
|
||||
((str.[!j] >= '0' && str.[!j] <= '9') ||
|
||||
(str.[!j] >= 'a' && str.[!j] <= 'f') ||
|
||||
(str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'o' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'f' | 'e' | 'g' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
|
||||
if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
|
||||
incr j;
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
|
||||
end;
|
||||
if !j > start then
|
||||
let f_val = float_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Number f_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 's' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
|
||||
if !j > start then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'c' ->
|
||||
if !i < len then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
|
||||
Hashtbl.replace d "consumed" (Integer (!i + 1));
|
||||
Dict d
|
||||
else Nil
|
||||
| _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> Nil);
|
||||
|
||||
register "parse-int" (fun args ->
|
||||
let parse_leading_int s =
|
||||
let len = String.length s in
|
||||
@@ -3576,204 +3399,6 @@ let () =
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
||||
|
||||
(* === Exec === run an external process; capture stdout *)
|
||||
register "exec-process" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-process: (cmd-list)")
|
||||
in
|
||||
let argv = Array.of_list (List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items) in
|
||||
if Array.length argv = 0 then raise (Eval_error "exec: empty command");
|
||||
let (out_r, out_w) = Unix.pipe () in
|
||||
let (err_r, err_w) = Unix.pipe () in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
Unix.close out_r; Unix.close out_w;
|
||||
Unix.close err_r; Unix.close err_w;
|
||||
raise (Eval_error ("exec: " ^ Unix.error_message e))
|
||||
in
|
||||
Unix.close out_w;
|
||||
Unix.close err_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let n = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if n = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 n
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all out_r buf;
|
||||
read_all err_r errbuf;
|
||||
Unix.close out_r;
|
||||
Unix.close err_r;
|
||||
let (_, status) = Unix.waitpid [] pid in
|
||||
let exit_code = match status with
|
||||
| Unix.WEXITED n -> n
|
||||
| Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if exit_code <> 0 then
|
||||
raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
|
||||
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
|
||||
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
|
||||
stage; raises Eval_error if the last stage exits non-zero. *)
|
||||
register "exec-pipeline" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
|
||||
in
|
||||
let words = List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items in
|
||||
if words = [] then raise (Eval_error "exec: empty command");
|
||||
let split_stages ws =
|
||||
let rec loop acc cur = function
|
||||
| [] -> List.rev (List.rev cur :: acc)
|
||||
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
|
||||
| w :: rest -> loop acc (w :: cur) rest
|
||||
in
|
||||
loop [] [] ws
|
||||
in
|
||||
let extract_redirs ws =
|
||||
let in_path = ref None in
|
||||
let out_path = ref None in
|
||||
let out_append = ref false in
|
||||
let err_path = ref None in
|
||||
let merge_err = ref false in
|
||||
let cleaned = ref [] in
|
||||
let rec loop = function
|
||||
| [] -> ()
|
||||
| "<" :: p :: rest -> in_path := Some p; loop rest
|
||||
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
|
||||
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
|
||||
| "2>@1" :: rest -> merge_err := true; loop rest
|
||||
| "2>" :: p :: rest -> err_path := Some p; loop rest
|
||||
| w :: rest -> cleaned := w :: !cleaned; loop rest
|
||||
in
|
||||
loop ws;
|
||||
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
|
||||
in
|
||||
let stages = List.map extract_redirs (split_stages words) in
|
||||
if stages = [] then raise (Eval_error "exec: no stages");
|
||||
let n = List.length stages in
|
||||
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
|
||||
let (final_r, final_w) = Unix.pipe () in
|
||||
let (errstash_r, errstash_w) = Unix.pipe () in
|
||||
let pids = ref [] in
|
||||
let close_safe fd = try Unix.close fd with _ -> () in
|
||||
let open_in_redir = function
|
||||
| None -> Unix.stdin
|
||||
| Some path ->
|
||||
(try Unix.openfile path [Unix.O_RDONLY] 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
|
||||
in
|
||||
let open_out_redir path append =
|
||||
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
|
||||
try Unix.openfile path flags 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
let stages_arr = Array.of_list stages in
|
||||
(try
|
||||
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
|
||||
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
|
||||
let argv = Array.of_list cleaned in
|
||||
let stdin_fd =
|
||||
if i = 0 then open_in_redir ip
|
||||
else fst pipes.(i - 1)
|
||||
in
|
||||
let stdout_fd =
|
||||
if i = n - 1 then
|
||||
(match op with
|
||||
| None -> final_w
|
||||
| Some path -> open_out_redir path app)
|
||||
else snd pipes.(i)
|
||||
in
|
||||
let stderr_fd =
|
||||
if merge then stdout_fd
|
||||
else (match ep with
|
||||
| None -> if i = n - 1 then errstash_w else Unix.stderr
|
||||
| Some path -> open_out_redir path false)
|
||||
in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
pids := pid :: !pids;
|
||||
if i > 0 then close_safe (fst pipes.(i - 1));
|
||||
if i < n - 1 then close_safe (snd pipes.(i));
|
||||
if i = 0 && ip <> None then close_safe stdin_fd;
|
||||
if i = n - 1 && op <> None then close_safe stdout_fd;
|
||||
if not merge && ep <> None then close_safe stderr_fd
|
||||
) stages_arr
|
||||
with e ->
|
||||
close_safe final_r; close_safe final_w;
|
||||
close_safe errstash_r; close_safe errstash_w;
|
||||
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
|
||||
raise e);
|
||||
close_safe final_w;
|
||||
close_safe errstash_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if r = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 r
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all final_r buf;
|
||||
read_all errstash_r errbuf;
|
||||
close_safe final_r;
|
||||
close_safe errstash_r;
|
||||
let exit_codes = List.rev_map (fun pid ->
|
||||
let (_, st) = Unix.waitpid [] pid in
|
||||
match st with
|
||||
| Unix.WEXITED c -> c
|
||||
| _ -> 1
|
||||
) !pids in
|
||||
let final_code = match List.rev exit_codes with
|
||||
| [] -> 0
|
||||
| last :: _ -> last
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if final_code <> 0 then
|
||||
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||
let resolve_inet_addr host =
|
||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||
|
||||
@@ -270,15 +270,6 @@
|
||||
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
|
||||
((= tt :name)
|
||||
(cond
|
||||
((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
|
||||
(let
|
||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
||||
(let
|
||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(len tokens)
|
||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
|
||||
((some (fn (q) (= q tv)) apl-quad-fn-names)
|
||||
(let
|
||||
((op-result (collect-ops tokens (+ i 1))))
|
||||
@@ -344,22 +335,10 @@
|
||||
((= tt :glyph)
|
||||
(cond
|
||||
((or (= tv "⍺") (= tv "⍵"))
|
||||
(if
|
||||
(and
|
||||
(< (+ i 1) (len tokens))
|
||||
(= (tok-type (nth tokens (+ i 1))) :assign))
|
||||
(let
|
||||
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
|
||||
(let
|
||||
((rhs-expr (parse-apl-expr rhs-tokens)))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(len tokens)
|
||||
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "val" :node (list :name tv)}))))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "val" :node (list :name tv)})))
|
||||
((= tv "∇")
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
@@ -414,13 +393,7 @@
|
||||
ni
|
||||
(append acc {:kind "fn" :node fn-node})))))))
|
||||
((apl-parse-op-glyph? tv)
|
||||
(if
|
||||
(or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
|
||||
(collect-segments-loop
|
||||
tokens
|
||||
(+ i 1)
|
||||
(append acc {:kind "fn" :node (list :fn-glyph tv)}))
|
||||
(collect-segments-loop tokens (+ i 1) acc)))
|
||||
(collect-segments-loop tokens (+ i 1) acc))
|
||||
(true (collect-segments-loop tokens (+ i 1) acc))))
|
||||
(true (collect-segments-loop tokens (+ i 1) acc))))))))
|
||||
|
||||
|
||||
@@ -808,25 +808,6 @@
|
||||
((picked (map (fn (i) (nth arr-ravel i)) kept)))
|
||||
(make-array (list (len picked)) picked))))))
|
||||
|
||||
(define
|
||||
apl-compress-first
|
||||
(fn
|
||||
(mask arr)
|
||||
(let
|
||||
((mask-ravel (get mask :ravel))
|
||||
(shape (get arr :shape))
|
||||
(ravel (get arr :ravel)))
|
||||
(if
|
||||
(< (len shape) 2)
|
||||
(apl-compress mask arr)
|
||||
(let
|
||||
((rows (first shape)) (cols (last shape)))
|
||||
(let
|
||||
((kept-rows (filter (fn (i) (not (= 0 (nth mask-ravel i)))) (range 0 rows))))
|
||||
(let
|
||||
((new-ravel (reduce (fn (acc r) (append acc (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) (list) kept-rows)))
|
||||
(make-array (cons (len kept-rows) (rest shape)) new-ravel))))))))
|
||||
|
||||
(define
|
||||
apl-primes
|
||||
(fn
|
||||
@@ -1004,28 +985,6 @@
|
||||
(some (fn (c) (= c 0)) codes)
|
||||
(some (fn (c) (= c (nth e 1))) codes)))))
|
||||
|
||||
(define apl-rng-state 12345)
|
||||
|
||||
(define apl-rng-seed! (fn (s) (set! apl-rng-state s)))
|
||||
|
||||
(define
|
||||
apl-rng-next!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(set!
|
||||
apl-rng-state
|
||||
(mod (+ (* apl-rng-state 1103515245) 12345) 2147483648))
|
||||
apl-rng-state)))
|
||||
|
||||
(define
|
||||
apl-roll
|
||||
(fn
|
||||
(arr)
|
||||
(let
|
||||
((n (if (scalar? arr) (first (get arr :ravel)) (first (get arr :ravel)))))
|
||||
(apl-scalar (+ apl-io (mod (apl-rng-next!) n))))))
|
||||
|
||||
(define
|
||||
apl-cartesian
|
||||
(fn
|
||||
|
||||
@@ -312,146 +312,3 @@
|
||||
"train: mean of ⍳10 has shape ()"
|
||||
(mksh (apl-run "(+/÷≢) ⍳10"))
|
||||
(list))
|
||||
|
||||
(apl-test
|
||||
"compress: 1 0 1 0 1 / 10 20 30 40 50"
|
||||
(mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
|
||||
(list 10 30 50))
|
||||
|
||||
(apl-test
|
||||
"compress: empty mask → empty"
|
||||
(mkrv (apl-run "0 0 0 / 1 2 3"))
|
||||
(list))
|
||||
|
||||
(apl-test
|
||||
"primes via classic idiom (multi-stmt)"
|
||||
(mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"primes via classic idiom (n=20)"
|
||||
(mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
|
||||
(list 2 3 5 7 11 13 17 19))
|
||||
|
||||
(apl-test
|
||||
"compress: filter even values"
|
||||
(mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
|
||||
(list 2 4 6))
|
||||
|
||||
(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
|
||||
|
||||
(apl-test
|
||||
"inline-assign: (2×x) + x←10 → 30"
|
||||
(mkrv (apl-run "(2 × x) + x ← 10"))
|
||||
(list 30))
|
||||
|
||||
(apl-test
|
||||
"inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
|
||||
(mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"inline-assign: x is reusable — x + x ← 7 → 14"
|
||||
(mkrv (apl-run "x + x ← 7"))
|
||||
(list 14))
|
||||
|
||||
(apl-test
|
||||
"inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
|
||||
(mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
|
||||
(list 16))
|
||||
|
||||
(begin (apl-rng-seed! 42) nil)
|
||||
|
||||
(apl-test
|
||||
"?10 with seed 42 → 8 (deterministic)"
|
||||
(mkrv (apl-run "?10"))
|
||||
(list 8))
|
||||
|
||||
(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
|
||||
|
||||
(apl-test
|
||||
"?100 stays in range"
|
||||
(let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
|
||||
true)
|
||||
|
||||
(begin (apl-rng-seed! 42) nil)
|
||||
|
||||
(apl-test
|
||||
"?10 with re-seed 42 → 8 (reproducible)"
|
||||
(mkrv (apl-run "?10"))
|
||||
(list 8))
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: load primes.apl returns dfn AST"
|
||||
(first (apl-run-file "lib/apl/tests/programs/primes.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: life.apl parses without error"
|
||||
(first (apl-run-file "lib/apl/tests/programs/life.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: quicksort.apl parses without error"
|
||||
(first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
|
||||
:dfn)
|
||||
|
||||
(apl-test
|
||||
"apl-run-file: source-then-call returns primes count"
|
||||
(mksh
|
||||
(apl-run
|
||||
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
|
||||
(list 10))
|
||||
|
||||
(apl-test
|
||||
"primes one-liner with ⍵-rebind: primes 30"
|
||||
(mkrv
|
||||
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29))
|
||||
|
||||
(apl-test
|
||||
"primes one-liner: primes 50"
|
||||
(mkrv
|
||||
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
|
||||
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
|
||||
|
||||
(apl-test
|
||||
"primes.apl loaded + called via apl-run-file"
|
||||
(mkrv
|
||||
(apl-run
|
||||
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
|
||||
(list 2 3 5 7 11 13 17 19))
|
||||
|
||||
(apl-test
|
||||
"primes.apl loaded — count of primes ≤ 100"
|
||||
(first
|
||||
(mksh
|
||||
(apl-run
|
||||
(str
|
||||
(file-read "lib/apl/tests/programs/primes.apl")
|
||||
" ⋄ primes 100"))))
|
||||
25)
|
||||
|
||||
(apl-test
|
||||
"⍉ monadic transpose 2x3 → 3x2"
|
||||
(mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
|
||||
(list 1 4 2 5 3 6))
|
||||
|
||||
(apl-test
|
||||
"⍉ transpose shape (3 2)"
|
||||
(mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
|
||||
(list 3 2))
|
||||
|
||||
(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
|
||||
|
||||
(apl-test
|
||||
"5 ⊣ 1 2 3 → 5 (left)"
|
||||
(mkrv (apl-run "5 ⊣ 1 2 3"))
|
||||
(list 5))
|
||||
|
||||
(apl-test
|
||||
"5 ⊢ 1 2 3 → 1 2 3 (right)"
|
||||
(mkrv (apl-run "5 ⊢ 1 2 3"))
|
||||
(list 1 2 3))
|
||||
|
||||
(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")
|
||||
|
||||
@@ -252,6 +252,8 @@
|
||||
|
||||
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
|
||||
|
||||
(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
|
||||
|
||||
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
|
||||
|
||||
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
|
||||
|
||||
@@ -39,11 +39,6 @@
|
||||
((= g "⊖") apl-reverse-first)
|
||||
((= g "⍋") apl-grade-up)
|
||||
((= g "⍒") apl-grade-down)
|
||||
((= g "?") apl-roll)
|
||||
((= g "⍉") apl-transpose)
|
||||
((= g "⊢") (fn (a) a))
|
||||
((= g "⊣") (fn (a) a))
|
||||
((= g "⍕") apl-quad-fmt)
|
||||
((= g "⎕FMT") apl-quad-fmt)
|
||||
((= g "⎕←") apl-quad-print)
|
||||
(else (error "no monadic fn for glyph")))))
|
||||
@@ -85,11 +80,6 @@
|
||||
((= g "∊") apl-member)
|
||||
((= g "⍳") apl-index-of)
|
||||
((= g "~") apl-without)
|
||||
((= g "/") apl-compress)
|
||||
((= g "⌿") apl-compress-first)
|
||||
((= g "⍉") apl-transpose-dyadic)
|
||||
((= g "⊢") (fn (a b) b))
|
||||
((= g "⊣") (fn (a b) a))
|
||||
(else (error "no dyadic fn for glyph")))))
|
||||
|
||||
(define
|
||||
@@ -129,14 +119,8 @@
|
||||
(let
|
||||
((nm (nth node 1)))
|
||||
(cond
|
||||
((= nm "⍺")
|
||||
(let
|
||||
((v (get env "⍺")))
|
||||
(if (= v nil) (get env "alpha") v)))
|
||||
((= nm "⍵")
|
||||
(let
|
||||
((v (get env "⍵")))
|
||||
(if (= v nil) (get env "omega") v)))
|
||||
((= nm "⍺") (get env "alpha"))
|
||||
((= nm "⍵") (get env "omega"))
|
||||
((= nm "⎕IO") (apl-quad-io))
|
||||
((= nm "⎕ML") (apl-quad-ml))
|
||||
((= nm "⎕FR") (apl-quad-fr))
|
||||
@@ -148,11 +132,7 @@
|
||||
(if
|
||||
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
||||
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
|
||||
(let
|
||||
((arg-val (apl-eval-ast arg env)))
|
||||
(let
|
||||
((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
|
||||
((apl-resolve-monadic fn-node new-env) arg-val))))))
|
||||
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
|
||||
((= tag :dyad)
|
||||
(let
|
||||
((fn-node (nth node 1))
|
||||
@@ -164,13 +144,9 @@
|
||||
(get env "nabla")
|
||||
(apl-eval-ast lhs env)
|
||||
(apl-eval-ast rhs env))
|
||||
(let
|
||||
((rhs-val (apl-eval-ast rhs env)))
|
||||
(let
|
||||
((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
|
||||
((apl-resolve-dyadic fn-node new-env)
|
||||
(apl-eval-ast lhs new-env)
|
||||
rhs-val))))))
|
||||
((apl-resolve-dyadic fn-node env)
|
||||
(apl-eval-ast lhs env)
|
||||
(apl-eval-ast rhs env)))))
|
||||
((= tag :program) (apl-eval-stmts (rest node) env))
|
||||
((= tag :dfn) node)
|
||||
((= tag :bracket)
|
||||
@@ -183,8 +159,6 @@
|
||||
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
|
||||
axis-exprs)))
|
||||
(apl-bracket-multi axes arr))))
|
||||
((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
|
||||
((= tag :assign) (apl-eval-ast (nth node 2) env))
|
||||
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
|
||||
|
||||
(define
|
||||
@@ -564,5 +538,3 @@
|
||||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||||
|
||||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
||||
|
||||
(define apl-run-file (fn (path) (apl-run (file-read path))))
|
||||
|
||||
@@ -76,7 +76,7 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||
EPOCHS
|
||||
|
||||
timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
|
||||
# Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||
parse_pair() {
|
||||
|
||||
@@ -1,16 +1,16 @@
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": 530,
|
||||
"total": 530,
|
||||
"total_pass": 0,
|
||||
"total": 0,
|
||||
"suites": [
|
||||
{"name":"tokenize","pass":62,"total":62,"status":"ok"},
|
||||
{"name":"parse","pass":52,"total":52,"status":"ok"},
|
||||
{"name":"eval","pass":346,"total":346,"status":"ok"},
|
||||
{"name":"runtime","pass":39,"total":39,"status":"ok"},
|
||||
{"name":"ring","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"ping-pong","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"bank","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"echo","pass":7,"total":7,"status":"ok"},
|
||||
{"name":"fib","pass":8,"total":8,"status":"ok"}
|
||||
{"name":"tokenize","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"parse","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"eval","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"runtime","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"ring","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"ping-pong","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"bank","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"echo","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"fib","pass":0,"total":0,"status":"ok"}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,18 +1,18 @@
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: 530 / 530 tests passing**
|
||||
**Total: 0 / 0 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | tokenize | 62 | 62 |
|
||||
| ✅ | parse | 52 | 52 |
|
||||
| ✅ | eval | 346 | 346 |
|
||||
| ✅ | runtime | 39 | 39 |
|
||||
| ✅ | ring | 4 | 4 |
|
||||
| ✅ | ping-pong | 4 | 4 |
|
||||
| ✅ | bank | 8 | 8 |
|
||||
| ✅ | echo | 7 | 7 |
|
||||
| ✅ | fib | 8 | 8 |
|
||||
| ✅ | tokenize | 0 | 0 |
|
||||
| ✅ | parse | 0 | 0 |
|
||||
| ✅ | eval | 0 | 0 |
|
||||
| ✅ | runtime | 0 | 0 |
|
||||
| ✅ | ring | 0 | 0 |
|
||||
| ✅ | ping-pong | 0 | 0 |
|
||||
| ✅ | bank | 0 | 0 |
|
||||
| ✅ | echo | 0 | 0 |
|
||||
| ✅ | fib | 0 | 0 |
|
||||
|
||||
|
||||
Generated by `lib/erlang/conformance.sh`.
|
||||
|
||||
@@ -210,6 +210,7 @@
|
||||
:op (nth node 1)
|
||||
(hk-desugar (nth node 2))
|
||||
(hk-desugar (nth node 3))))
|
||||
((= tag "type-ann") (hk-desugar (nth node 1)))
|
||||
((= tag "neg") (list :neg (hk-desugar (nth node 1))))
|
||||
((= tag "if")
|
||||
(list
|
||||
|
||||
@@ -275,38 +275,47 @@
|
||||
(list :sect-right op-name expr-e))))))
|
||||
(:else
|
||||
(let
|
||||
((first-e (hk-parse-expr-inner))
|
||||
(items (list))
|
||||
(is-tuple false))
|
||||
(append! items first-e)
|
||||
(define
|
||||
hk-tup-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(set! is-tuple true)
|
||||
(append! items (hk-parse-expr-inner))
|
||||
(hk-tup-loop)))))
|
||||
(hk-tup-loop)
|
||||
((first-e (hk-parse-expr-inner)))
|
||||
(cond
|
||||
((hk-match? "rparen" nil)
|
||||
((hk-match? "reservedop" "::")
|
||||
(do
|
||||
(hk-advance!)
|
||||
(if is-tuple (list :tuple items) first-e)))
|
||||
(let
|
||||
((ann-type (hk-parse-type)))
|
||||
(hk-expect! "rparen" nil)
|
||||
(list :type-ann first-e ann-type))))
|
||||
(:else
|
||||
(let
|
||||
((op-info2 (hk-section-op-info)))
|
||||
((items (list)) (is-tuple false))
|
||||
(append! items first-e)
|
||||
(define
|
||||
hk-tup-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(hk-match? "comma" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(set! is-tuple true)
|
||||
(append! items (hk-parse-expr-inner))
|
||||
(hk-tup-loop)))))
|
||||
(hk-tup-loop)
|
||||
(cond
|
||||
((and (not (nil? op-info2)) (not is-tuple) (let ((after2 (hk-peek-at (get op-info2 "len")))) (and (not (nil? after2)) (= (get after2 "type") "rparen"))))
|
||||
(let
|
||||
((op-name (get op-info2 "name")))
|
||||
(hk-consume-op!)
|
||||
((hk-match? "rparen" nil)
|
||||
(do
|
||||
(hk-advance!)
|
||||
(list :sect-left op-name first-e)))
|
||||
(:else (hk-err "expected ')' after expression"))))))))))))))
|
||||
(if is-tuple (list :tuple items) first-e)))
|
||||
(:else
|
||||
(let
|
||||
((op-info2 (hk-section-op-info)))
|
||||
(cond
|
||||
((and (not (nil? op-info2)) (not is-tuple) (let ((after2 (hk-peek-at (get op-info2 "len")))) (and (not (nil? after2)) (= (get after2 "type") "rparen"))))
|
||||
(let
|
||||
((op-name (get op-info2 "name")))
|
||||
(hk-consume-op!)
|
||||
(hk-advance!)
|
||||
(list :sect-left op-name first-e)))
|
||||
(:else (hk-err "expected ')' after expression")))))))))))))))))
|
||||
(define
|
||||
hk-comp-qual-is-gen?
|
||||
(fn
|
||||
@@ -1724,10 +1733,18 @@
|
||||
(= (hk-peek-type) "eof")
|
||||
(hk-match? "vrbrace" nil)
|
||||
(hk-match? "rbrace" nil))))
|
||||
(define
|
||||
hk-body-step
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((hk-match? "reserved" "import")
|
||||
(append! imports (hk-parse-import)))
|
||||
(:else (append! decls (hk-parse-decl))))))
|
||||
(when
|
||||
(not (hk-body-at-end?))
|
||||
(do
|
||||
(append! decls (hk-parse-decl))
|
||||
(hk-body-step)
|
||||
(define
|
||||
hk-body-loop
|
||||
(fn
|
||||
@@ -1738,7 +1755,7 @@
|
||||
(hk-advance!)
|
||||
(when
|
||||
(not (hk-body-at-end?))
|
||||
(append! decls (hk-parse-decl)))
|
||||
(hk-body-step))
|
||||
(hk-body-loop)))))
|
||||
(hk-body-loop)))
|
||||
(list imports decls))))
|
||||
|
||||
102
lib/haskell/tests/parse-extras.sx
Normal file
102
lib/haskell/tests/parse-extras.sx
Normal file
@@ -0,0 +1,102 @@
|
||||
;; Phase 17 — parser polish unit tests.
|
||||
|
||||
(hk-test
|
||||
"type-ann: literal int annotated"
|
||||
(hk-deep-force (hk-run "main = (42 :: Int)"))
|
||||
42)
|
||||
|
||||
(hk-test
|
||||
"type-ann: arithmetic annotated"
|
||||
(hk-deep-force (hk-run "main = (1 + 2 :: Int)"))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"type-ann: function arg annotated"
|
||||
(hk-deep-force
|
||||
(hk-run "f x = x + 1\nmain = f (1 :: Int)"))
|
||||
2)
|
||||
|
||||
(hk-test
|
||||
"type-ann: string annotated"
|
||||
(hk-deep-force (hk-run "main = (\"hi\" :: String)"))
|
||||
"hi")
|
||||
|
||||
(hk-test
|
||||
"type-ann: bool annotated"
|
||||
(hk-deep-force (hk-run "main = (True :: Bool)"))
|
||||
(list "True"))
|
||||
|
||||
(hk-test
|
||||
"type-ann: tuple annotated"
|
||||
(hk-deep-force (hk-run "main = ((1, 2) :: (Int, Int))"))
|
||||
(list "Tuple" 1 2))
|
||||
|
||||
(hk-test
|
||||
"type-ann: nested annotation in arithmetic"
|
||||
(hk-deep-force (hk-run "main = (1 :: Int) + (2 :: Int)"))
|
||||
3)
|
||||
|
||||
(hk-test
|
||||
"type-ann: function-typed annotation passes through eval"
|
||||
(hk-deep-force
|
||||
(hk-run "main = let f = ((\\x -> x + 1) :: Int -> Int) in f 5"))
|
||||
6)
|
||||
|
||||
(hk-test
|
||||
"no regression: plain parens still work"
|
||||
(hk-deep-force (hk-run "main = (5)"))
|
||||
5)
|
||||
|
||||
(hk-test
|
||||
"no regression: 3-tuple still works"
|
||||
(hk-deep-force (hk-run "main = (1, 2, 3)"))
|
||||
(list "Tuple" 1 2 3))
|
||||
|
||||
(hk-test
|
||||
"no regression: section-left still works"
|
||||
(hk-deep-force (hk-run "main = (3 +) 4"))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"no regression: section-right still works"
|
||||
(hk-deep-force (hk-run "main = (+ 3) 4"))
|
||||
7)
|
||||
|
||||
(hk-test
|
||||
"import: still works as the very first decl"
|
||||
(hk-deep-force
|
||||
(hk-run "import qualified Data.IORef as I
|
||||
main = do { r <- I.newIORef 7; I.readIORef r }"))
|
||||
(list "IO" 7))
|
||||
|
||||
(hk-test
|
||||
"import: between decls — after main"
|
||||
(hk-deep-force
|
||||
(hk-run "main = do { r <- I.newIORef 11; I.readIORef r }
|
||||
import qualified Data.IORef as I"))
|
||||
(list "IO" 11))
|
||||
|
||||
(hk-test
|
||||
"import: between two decls — uses helper after import"
|
||||
(hk-deep-force
|
||||
(hk-run "f x = x + 100
|
||||
import qualified Data.IORef as I
|
||||
main = do { r <- I.newIORef 5; I.modifyIORef r f; I.readIORef r }"))
|
||||
(list "IO" 105))
|
||||
|
||||
(hk-test
|
||||
"import: two imports in different positions"
|
||||
(hk-deep-force
|
||||
(hk-run "import qualified Data.IORef as I
|
||||
helper x = x * 2
|
||||
import qualified Data.Map as M
|
||||
main = do { r <- I.newIORef (helper 21); I.readIORef r }"))
|
||||
(list "IO" 42))
|
||||
|
||||
(hk-test
|
||||
"import: unqualified, mid-file"
|
||||
(hk-deep-force
|
||||
(hk-run "go x = x
|
||||
import Data.IORef
|
||||
main = go 9"))
|
||||
9)
|
||||
@@ -16,15 +16,18 @@
|
||||
true)))
|
||||
|
||||
;; ─── Valid programs pass through ─────────────────────────────────────────────
|
||||
(hk-test "typed ok: simple arithmetic" (hk-run-typed "main = 1 + 2") 3)
|
||||
(hk-test "typed ok: simple arithmetic"
|
||||
(hk-deep-force (hk-run-typed "main = 1 + 2")) 3)
|
||||
|
||||
(hk-test "typed ok: boolean" (hk-run-typed "main = True") (list "True"))
|
||||
(hk-test "typed ok: boolean"
|
||||
(hk-deep-force (hk-run-typed "main = True")) (list "True"))
|
||||
|
||||
(hk-test "typed ok: let binding" (hk-run-typed "main = let x = 1 in x + 2") 3)
|
||||
(hk-test "typed ok: let binding"
|
||||
(hk-deep-force (hk-run-typed "main = let x = 1 in x + 2")) 3)
|
||||
|
||||
(hk-test
|
||||
"typed ok: two independent fns"
|
||||
(hk-run-typed "f x = x + 1\nmain = f 5")
|
||||
(hk-deep-force (hk-run-typed "f x = x + 1\nmain = f 5"))
|
||||
6)
|
||||
|
||||
;; ─── Untypeable programs are rejected ────────────────────────────────────────
|
||||
@@ -76,7 +79,7 @@
|
||||
|
||||
(hk-test
|
||||
"run-typed sig ok: Int declared matches"
|
||||
(hk-run-typed "main :: Int\nmain = 1 + 2")
|
||||
(hk-deep-force (hk-run-typed "main :: Int\nmain = 1 + 2"))
|
||||
3)
|
||||
|
||||
{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}
|
||||
@@ -226,28 +226,6 @@
|
||||
value)
|
||||
(list (quote set!) (hs-to-sx target) value)))))))
|
||||
(true (list (quote set!) (hs-to-sx target) value)))))))
|
||||
;; Throttle/debounce extraction state — module-level so they don't get
|
||||
;; redefined on every emit-on call (which was causing JIT churn). Set
|
||||
;; via _strip-throttle-debounce at the start of each emit-on, used in
|
||||
;; the handler-build step inside scan-on.
|
||||
(define _throttle-ms nil)
|
||||
(define _debounce-ms nil)
|
||||
(define
|
||||
_strip-throttle-debounce
|
||||
(fn
|
||||
(lst)
|
||||
(cond
|
||||
((<= (len lst) 1) lst)
|
||||
((= (first lst) :throttle)
|
||||
(do
|
||||
(set! _throttle-ms (nth lst 1))
|
||||
(_strip-throttle-debounce (rest (rest lst)))))
|
||||
((= (first lst) :debounce)
|
||||
(do
|
||||
(set! _debounce-ms (nth lst 1))
|
||||
(_strip-throttle-debounce (rest (rest lst)))))
|
||||
(true
|
||||
(cons (first lst) (_strip-throttle-debounce (rest lst)))))))
|
||||
(define
|
||||
emit-on
|
||||
(fn
|
||||
@@ -256,8 +234,6 @@
|
||||
((parts (rest ast)))
|
||||
(let
|
||||
((event-name (first parts)))
|
||||
(set! _throttle-ms nil)
|
||||
(set! _debounce-ms nil)
|
||||
(define
|
||||
scan-on
|
||||
(fn
|
||||
@@ -290,13 +266,6 @@
|
||||
((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
|
||||
(let
|
||||
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
|
||||
(let
|
||||
((handler (cond
|
||||
(_throttle-ms
|
||||
(list (quote hs-throttle!) handler (hs-to-sx _throttle-ms)))
|
||||
(_debounce-ms
|
||||
(list (quote hs-debounce!) handler (hs-to-sx _debounce-ms)))
|
||||
(true handler))))
|
||||
(let
|
||||
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
|
||||
(cond
|
||||
@@ -356,7 +325,7 @@
|
||||
(first pair)
|
||||
handler))
|
||||
or-sources)))
|
||||
on-call))))))))))))))
|
||||
on-call)))))))))))))
|
||||
((= (first items) :from)
|
||||
(scan-on
|
||||
(rest (rest items))
|
||||
@@ -500,7 +469,7 @@
|
||||
count-filter-info
|
||||
elsewhere?
|
||||
or-sources)))))
|
||||
(scan-on (_strip-throttle-debounce (rest parts)) nil nil false nil nil nil nil nil false nil)))))
|
||||
(scan-on (rest parts) nil nil false nil nil nil nil nil false nil)))))
|
||||
(define
|
||||
emit-send
|
||||
(fn
|
||||
@@ -2521,15 +2490,6 @@
|
||||
(quote fn)
|
||||
(list (quote it))
|
||||
(hs-to-sx body))))
|
||||
((and (list? expr) (= (first expr) (quote attr)))
|
||||
(list
|
||||
(quote hs-attr-watch!)
|
||||
(hs-to-sx (nth expr 2))
|
||||
(nth expr 1)
|
||||
(list
|
||||
(quote fn)
|
||||
(list (quote it))
|
||||
(hs-to-sx body))))
|
||||
(true nil))))
|
||||
((= head (quote init))
|
||||
(list
|
||||
|
||||
@@ -1358,17 +1358,7 @@
|
||||
cls
|
||||
(first extra-classes)
|
||||
tgt))
|
||||
((and
|
||||
(= (tp-type) "keyword") (= (tp-val) "for")
|
||||
;; Only consume 'for' as a duration clause if the next
|
||||
;; token is NOT '<ident> in ...' — that pattern is a
|
||||
;; for-in loop, not a toggle duration.
|
||||
(not
|
||||
(and
|
||||
(> (len tokens) (+ p 2))
|
||||
(= (get (nth tokens (+ p 1)) "type") "ident")
|
||||
(= (get (nth tokens (+ p 2)) "value") "in")))
|
||||
(do (adv!) true))
|
||||
((match-kw "for")
|
||||
(let
|
||||
((dur (parse-expr)))
|
||||
(list (quote toggle-class-for) cls tgt dur)))
|
||||
@@ -3100,17 +3090,7 @@
|
||||
(= (tp-val) "queue"))
|
||||
(do (adv!) (adv!)))
|
||||
(let
|
||||
((every? (match-kw "every"))
|
||||
(throttle-ms nil)
|
||||
(debounce-ms nil))
|
||||
;; 'throttled at <duration>' / 'debounced at <duration>'
|
||||
;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
|
||||
(when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
|
||||
(adv!)
|
||||
(when (match-kw "at") (set! throttle-ms (parse-expr))))
|
||||
(when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
|
||||
(adv!)
|
||||
(when (match-kw "at") (set! debounce-ms (parse-expr))))
|
||||
((every? (match-kw "every")))
|
||||
(let
|
||||
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
|
||||
(let
|
||||
@@ -3125,10 +3105,6 @@
|
||||
(match-kw "end")
|
||||
(let
|
||||
((parts (list (quote on) event-name)))
|
||||
(let
|
||||
((parts (if throttle-ms (append parts (list :throttle throttle-ms)) parts)))
|
||||
(let
|
||||
((parts (if debounce-ms (append parts (list :debounce debounce-ms)) parts)))
|
||||
(let
|
||||
((parts (if every? (append parts (list :every true)) parts)))
|
||||
(let
|
||||
@@ -3151,7 +3127,7 @@
|
||||
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
|
||||
(let
|
||||
((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body)))))
|
||||
parts))))))))))))))))))))))))))))
|
||||
parts))))))))))))))))))))))))))
|
||||
(define
|
||||
parse-init-feat
|
||||
(fn
|
||||
@@ -3201,7 +3177,6 @@
|
||||
(or
|
||||
(= (tp-type) "hat")
|
||||
(= (tp-type) "local")
|
||||
(= (tp-type) "attr")
|
||||
(and (= (tp-type) "keyword") (= (tp-val) "dom")))
|
||||
(let
|
||||
((expr (parse-expr)))
|
||||
|
||||
@@ -12,29 +12,6 @@
|
||||
|
||||
;; Register an event listener. Returns unlisten function.
|
||||
;; (hs-on target event-name handler) → unlisten-fn
|
||||
(begin
|
||||
(define _hs-config-log-all false)
|
||||
(define _hs-log-captured (list))
|
||||
(define
|
||||
hs-set-log-all!
|
||||
(fn (flag) (set! _hs-config-log-all (if flag true false))))
|
||||
(define hs-get-log-captured (fn () _hs-log-captured))
|
||||
(define
|
||||
hs-clear-log-captured!
|
||||
(fn () (begin (set! _hs-log-captured (list)) nil)))
|
||||
(define
|
||||
hs-log-event!
|
||||
(fn
|
||||
(msg)
|
||||
(when
|
||||
_hs-config-log-all
|
||||
(begin
|
||||
(set! _hs-log-captured (append _hs-log-captured (list msg)))
|
||||
(host-call (host-global "console") "log" msg)
|
||||
nil)))))
|
||||
|
||||
;; Run an initializer function immediately.
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define
|
||||
hs-each
|
||||
(fn
|
||||
@@ -45,52 +22,17 @@
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define meta (host-new "Object"))
|
||||
|
||||
;; Run an initializer function immediately.
|
||||
;; (hs-init thunk) — called at element boot time
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; ── Async / timing ──────────────────────────────────────────────
|
||||
|
||||
;; Wait for a duration in milliseconds.
|
||||
;; In hyperscript, wait is async-transparent — execution pauses.
|
||||
;; Here we use perform/IO suspension for true pause semantics.
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; Throttle: drops events that arrive within the window. First event fires
|
||||
;; immediately; subsequent events within `ms` of the previous fire are dropped.
|
||||
;; Returns a wrapped handler suitable for hs-on / hs-on-every.
|
||||
(define
|
||||
hs-throttle!
|
||||
(fn
|
||||
(handler ms)
|
||||
(let
|
||||
((__hs-last-fire 0))
|
||||
(fn
|
||||
(event)
|
||||
(let
|
||||
((__hs-now (host-call (host-global "Date") "now")))
|
||||
(when
|
||||
(>= (- __hs-now __hs-last-fire) ms)
|
||||
(set! __hs-last-fire __hs-now)
|
||||
(handler event)))))))
|
||||
|
||||
;; Debounce: waits until `ms` has elapsed since the last event before firing.
|
||||
;; In our synchronous test mock no time passes, so the timer fires immediately
|
||||
;; via setTimeout(_, 0); the wrapped handler still gets called once per burst.
|
||||
(define
|
||||
hs-debounce!
|
||||
(fn
|
||||
(handler ms)
|
||||
(let
|
||||
((__hs-timer nil))
|
||||
(fn
|
||||
(event)
|
||||
(when __hs-timer (host-call (host-global "window") "clearTimeout" __hs-timer))
|
||||
(set! __hs-timer
|
||||
(host-call (host-global "window") "setTimeout"
|
||||
(host-new-function (list "ev") "return arguments[0](arguments[1]);")
|
||||
ms handler event))))))
|
||||
|
||||
;; Wait for a DOM event on a target.
|
||||
;; (hs-wait-for target event-name) — suspends until event fires
|
||||
(define
|
||||
_hs-on-caller
|
||||
(let
|
||||
@@ -103,7 +45,8 @@
|
||||
(host-set! _ctx "meta" _m)
|
||||
_ctx)))
|
||||
|
||||
;; Wait for CSS transitions/animations to settle on an element.
|
||||
;; Wait for a DOM event on a target.
|
||||
;; (hs-wait-for target event-name) — suspends until event fires
|
||||
(define
|
||||
hs-on
|
||||
(fn
|
||||
@@ -123,14 +66,14 @@
|
||||
(append prev (list unlisten)))
|
||||
unlisten))))))
|
||||
|
||||
;; ── Class manipulation ──────────────────────────────────────────
|
||||
|
||||
;; Toggle a single class on an element.
|
||||
;; Wait for CSS transitions/animations to settle on an element.
|
||||
(define
|
||||
hs-on-every
|
||||
(fn (target event-name handler) (dom-listen target event-name handler)))
|
||||
|
||||
;; Toggle between two classes — exactly one is active at a time.
|
||||
;; ── Class manipulation ──────────────────────────────────────────
|
||||
|
||||
;; Toggle a single class on an element.
|
||||
(define
|
||||
hs-on-intersection-attach!
|
||||
(fn
|
||||
@@ -146,8 +89,7 @@
|
||||
(host-call observer "observe" target)
|
||||
observer)))))
|
||||
|
||||
;; Take a class from siblings — add to target, remove from others.
|
||||
;; (hs-take! target cls) — like radio button class behavior
|
||||
;; Toggle between two classes — exactly one is active at a time.
|
||||
(define
|
||||
hs-on-mutation-attach!
|
||||
(fn
|
||||
@@ -168,18 +110,19 @@
|
||||
(host-call observer "observe" target opts)
|
||||
observer))))))
|
||||
|
||||
;; Take a class from siblings — add to target, remove from others.
|
||||
;; (hs-take! target cls) — like radio button class behavior
|
||||
(define hs-init (fn (thunk) (thunk)))
|
||||
|
||||
;; ── DOM insertion ───────────────────────────────────────────────
|
||||
|
||||
;; Put content at a position relative to a target.
|
||||
;; pos: "into" | "before" | "after"
|
||||
(define hs-init (fn (thunk) (thunk)))
|
||||
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
||||
|
||||
;; ── Navigation / traversal ──────────────────────────────────────
|
||||
|
||||
;; Navigate to a URL.
|
||||
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
|
||||
|
||||
;; Find next sibling matching a selector (or any sibling).
|
||||
(begin
|
||||
(define
|
||||
hs-wait-for
|
||||
@@ -192,7 +135,7 @@
|
||||
(target event-name timeout-ms)
|
||||
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
|
||||
|
||||
;; Find previous sibling matching a selector.
|
||||
;; Find next sibling matching a selector (or any sibling).
|
||||
(define
|
||||
hs-settle
|
||||
(fn
|
||||
@@ -200,7 +143,7 @@
|
||||
(hs-null-raise! target)
|
||||
(when (not (nil? target)) (perform (list (quote io-settle) target)))))
|
||||
|
||||
;; First element matching selector within a scope.
|
||||
;; Find previous sibling matching a selector.
|
||||
(define
|
||||
hs-toggle-class!
|
||||
(fn
|
||||
@@ -210,7 +153,7 @@
|
||||
(not (nil? target))
|
||||
(host-call (host-get target "classList") "toggle" cls))))
|
||||
|
||||
;; Last element matching selector.
|
||||
;; First element matching selector within a scope.
|
||||
(define
|
||||
hs-toggle-var-cycle!
|
||||
(fn
|
||||
@@ -232,7 +175,7 @@
|
||||
var-name
|
||||
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
|
||||
|
||||
;; First/last within a specific scope.
|
||||
;; Last element matching selector.
|
||||
(define
|
||||
hs-toggle-between!
|
||||
(fn
|
||||
@@ -245,6 +188,7 @@
|
||||
(do (dom-remove-class target cls1) (dom-add-class target cls2))
|
||||
(do (dom-remove-class target cls2) (dom-add-class target cls1))))))
|
||||
|
||||
;; First/last within a specific scope.
|
||||
(define
|
||||
hs-toggle-style!
|
||||
(fn
|
||||
@@ -268,9 +212,6 @@
|
||||
(dom-set-style target prop "hidden")
|
||||
(dom-set-style target prop "")))))))
|
||||
|
||||
;; ── Iteration ───────────────────────────────────────────────────
|
||||
|
||||
;; Repeat a thunk N times.
|
||||
(define
|
||||
hs-toggle-style-between!
|
||||
(fn
|
||||
@@ -282,7 +223,9 @@
|
||||
(dom-set-style target prop val2)
|
||||
(dom-set-style target prop val1)))))
|
||||
|
||||
;; Repeat forever (until break — relies on exception/continuation).
|
||||
;; ── Iteration ───────────────────────────────────────────────────
|
||||
|
||||
;; Repeat a thunk N times.
|
||||
(define
|
||||
hs-toggle-style-cycle!
|
||||
(fn
|
||||
@@ -303,10 +246,7 @@
|
||||
(true (find-next (rest remaining))))))
|
||||
(dom-set-style target prop (find-next vals)))))
|
||||
|
||||
;; ── Fetch ───────────────────────────────────────────────────────
|
||||
|
||||
;; Fetch a URL, parse response according to format.
|
||||
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
||||
;; Repeat forever (until break — relies on exception/continuation).
|
||||
(define
|
||||
hs-take!
|
||||
(fn
|
||||
@@ -329,7 +269,8 @@
|
||||
(when with-cls (dom-remove-class target with-cls))))
|
||||
(let
|
||||
((attr-val (if (> (len extra) 0) (first extra) nil))
|
||||
(with-val (if (> (len extra) 1) (nth extra 1) nil)))
|
||||
(with-val
|
||||
(if (> (len extra) 1) (nth extra 1) nil)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
@@ -346,10 +287,10 @@
|
||||
(dom-set-attr target name attr-val)
|
||||
(dom-set-attr target name ""))))))))
|
||||
|
||||
;; ── Type coercion ───────────────────────────────────────────────
|
||||
;; ── Fetch ───────────────────────────────────────────────────────
|
||||
|
||||
;; Coerce a value to a type by name.
|
||||
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
||||
;; Fetch a URL, parse response according to format.
|
||||
;; (hs-fetch url format) — format is "json" | "text" | "html"
|
||||
(begin
|
||||
(define
|
||||
hs-element?
|
||||
@@ -506,10 +447,10 @@
|
||||
(dom-insert-adjacent-html target "beforeend" value)
|
||||
(hs-boot-subtree! target)))))))))))
|
||||
|
||||
;; ── Object creation ─────────────────────────────────────────────
|
||||
;; ── Type coercion ───────────────────────────────────────────────
|
||||
|
||||
;; Make a new object of a given type.
|
||||
;; (hs-make type-name) — creates empty object/collection
|
||||
;; Coerce a value to a type by name.
|
||||
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
|
||||
(define
|
||||
hs-add-to!
|
||||
(fn
|
||||
@@ -523,11 +464,10 @@
|
||||
((hs-is-set? target) (do (host-call target "add" value) target))
|
||||
(true (do (host-call target "push" value) target)))))
|
||||
|
||||
;; ── Behavior installation ───────────────────────────────────────
|
||||
;; ── Object creation ─────────────────────────────────────────────
|
||||
|
||||
;; Install a behavior on an element.
|
||||
;; A behavior is a function that takes (me ...params) and sets up features.
|
||||
;; (hs-install behavior-fn me ...args)
|
||||
;; Make a new object of a given type.
|
||||
;; (hs-make type-name) — creates empty object/collection
|
||||
(define
|
||||
hs-remove-from!
|
||||
(fn
|
||||
@@ -537,10 +477,11 @@
|
||||
((hs-is-set? target) (do (host-call target "delete" value) target))
|
||||
(true (host-call target "splice" (host-call target "indexOf" value) 1)))))
|
||||
|
||||
;; ── Measurement ─────────────────────────────────────────────────
|
||||
;; ── Behavior installation ───────────────────────────────────────
|
||||
|
||||
;; Measure an element's bounding rect, store as local variables.
|
||||
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
||||
;; Install a behavior on an element.
|
||||
;; A behavior is a function that takes (me ...params) and sets up features.
|
||||
;; (hs-install behavior-fn me ...args)
|
||||
(define
|
||||
hs-splice-at!
|
||||
(fn
|
||||
@@ -553,7 +494,10 @@
|
||||
((i (if (< idx 0) (+ n idx) idx)))
|
||||
(cond
|
||||
((or (< i 0) (>= i n)) target)
|
||||
(true (concat (slice target 0 i) (slice target (+ i 1) n))))))
|
||||
(true
|
||||
(concat
|
||||
(slice target 0 i)
|
||||
(slice target (+ i 1) n))))))
|
||||
(do
|
||||
(when
|
||||
target
|
||||
@@ -564,10 +508,10 @@
|
||||
(host-call target "splice" i 1))))
|
||||
target))))
|
||||
|
||||
;; Return the current text selection as a string. In the browser this is
|
||||
;; `window.getSelection().toString()`. In the mock test runner, a test
|
||||
;; setup stashes the desired selection text at `window.__test_selection`
|
||||
;; and the fallback path returns that so tests can assert on the result.
|
||||
;; ── Measurement ─────────────────────────────────────────────────
|
||||
|
||||
;; Measure an element's bounding rect, store as local variables.
|
||||
;; Returns a dict with x, y, width, height, top, left, right, bottom.
|
||||
(define
|
||||
hs-index
|
||||
(fn
|
||||
@@ -579,11 +523,10 @@
|
||||
((string? obj) (nth obj key))
|
||||
(true (host-get obj key)))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
;; Return the current text selection as a string. In the browser this is
|
||||
;; `window.getSelection().toString()`. In the mock test runner, a test
|
||||
;; setup stashes the desired selection text at `window.__test_selection`
|
||||
;; and the fallback path returns that so tests can assert on the result.
|
||||
(define
|
||||
hs-put-at!
|
||||
(fn
|
||||
@@ -605,6 +548,11 @@
|
||||
((= pos "start") (host-call target "unshift" value)))
|
||||
target)))))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-dict-without
|
||||
(fn
|
||||
@@ -641,11 +589,6 @@
|
||||
((w (host-global "window")))
|
||||
(if w (host-call w "prompt" msg) nil))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-answer
|
||||
(fn
|
||||
@@ -654,6 +597,11 @@
|
||||
((w (host-global "window")))
|
||||
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
|
||||
|
||||
|
||||
;; ── Transition ──────────────────────────────────────────────────
|
||||
|
||||
;; Transition a CSS property to a value, optionally with duration.
|
||||
;; (hs-transition target prop value duration)
|
||||
(define
|
||||
hs-answer-alert
|
||||
(fn
|
||||
@@ -714,10 +662,6 @@
|
||||
(if (nil? sel) "" (host-call sel "toString" (list))))
|
||||
stash)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define
|
||||
hs-reset!
|
||||
(fn
|
||||
@@ -764,6 +708,10 @@
|
||||
(when default-val (dom-set-prop target "value" default-val)))))
|
||||
(true nil)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define
|
||||
hs-next
|
||||
(fn
|
||||
@@ -782,8 +730,7 @@
|
||||
((dom-matches? el sel) el)
|
||||
(true (find-next (dom-next-sibling el))))))
|
||||
(find-next sibling)))))
|
||||
;; ── Sandbox/test runtime additions ──────────────────────────────
|
||||
;; Property access — dot notation and .length
|
||||
|
||||
(define
|
||||
hs-previous
|
||||
(fn
|
||||
@@ -802,9 +749,10 @@
|
||||
((dom-matches? el sel) el)
|
||||
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
|
||||
(find-prev sibling)))))
|
||||
;; DOM query stub — sandbox returns empty list
|
||||
;; ── Sandbox/test runtime additions ──────────────────────────────
|
||||
;; Property access — dot notation and .length
|
||||
(define _hs-last-query-sel nil)
|
||||
;; Method dispatch — obj.method(args)
|
||||
;; DOM query stub — sandbox returns empty list
|
||||
(define
|
||||
hs-null-raise!
|
||||
(fn
|
||||
@@ -815,9 +763,7 @@
|
||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg))))))
|
||||
|
||||
;; ── 0.9.90 features ─────────────────────────────────────────────
|
||||
;; beep! — debug logging, returns value unchanged
|
||||
;; Method dispatch — obj.method(args)
|
||||
(define
|
||||
hs-empty-raise!
|
||||
(fn
|
||||
@@ -831,7 +777,9 @@
|
||||
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg))))))
|
||||
;; Property-based is — check obj.key truthiness
|
||||
|
||||
;; ── 0.9.90 features ─────────────────────────────────────────────
|
||||
;; beep! — debug logging, returns value unchanged
|
||||
(define
|
||||
hs-query-all-checked
|
||||
(fn
|
||||
@@ -839,14 +787,14 @@
|
||||
(let
|
||||
((result (hs-query-all sel)))
|
||||
(do (hs-empty-raise! result) result))))
|
||||
;; Array slicing (inclusive both ends)
|
||||
;; Property-based is — check obj.key truthiness
|
||||
(define
|
||||
hs-dispatch!
|
||||
(fn
|
||||
(target event detail)
|
||||
(hs-null-raise! target)
|
||||
(when (not (nil? target)) (dom-dispatch target event detail))))
|
||||
;; Collection: sorted by
|
||||
;; Array slicing (inclusive both ends)
|
||||
(define
|
||||
hs-query-all
|
||||
(fn
|
||||
@@ -854,7 +802,7 @@
|
||||
(do
|
||||
(host-set! (host-global "window") "_hs_last_query_sel" sel)
|
||||
(dom-query-all (dom-document) sel))))
|
||||
;; Collection: sorted by descending
|
||||
;; Collection: sorted by
|
||||
(define
|
||||
hs-query-all-in
|
||||
(fn
|
||||
@@ -863,17 +811,17 @@
|
||||
(nil? target)
|
||||
(hs-query-all sel)
|
||||
(host-call target "querySelectorAll" sel))))
|
||||
;; Collection: split by
|
||||
;; Collection: sorted by descending
|
||||
(define
|
||||
hs-list-set
|
||||
(fn
|
||||
(lst idx val)
|
||||
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
|
||||
;; Collection: joined by
|
||||
;; Collection: split by
|
||||
(define
|
||||
hs-to-number
|
||||
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
|
||||
|
||||
;; Collection: joined by
|
||||
(define
|
||||
hs-query-first
|
||||
(fn
|
||||
@@ -1003,7 +951,7 @@
|
||||
((= (str ex) "hs-continue") (do-loop (rest remaining)))
|
||||
(true (raise ex))))))))
|
||||
(do-loop items))))
|
||||
;; Collection: joined by
|
||||
|
||||
(begin
|
||||
(define
|
||||
hs-append
|
||||
@@ -1044,7 +992,7 @@
|
||||
(host-get value "outerHTML")
|
||||
(str value))))
|
||||
(true nil)))))
|
||||
|
||||
;; Collection: joined by
|
||||
(define
|
||||
hs-sender
|
||||
(fn
|
||||
@@ -1136,7 +1084,6 @@
|
||||
(hs-host-to-sx (perform (list "io-parse-json" raw))))
|
||||
((= fmt "number")
|
||||
(hs-to-number (perform (list "io-parse-text" raw))))
|
||||
((= fmt "html") (perform (list "io-parse-html" raw)))
|
||||
(true (perform (list "io-parse-text" raw)))))))))
|
||||
|
||||
(define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
|
||||
@@ -1676,10 +1623,14 @@
|
||||
((ch (substring sel i (+ i 1))))
|
||||
(cond
|
||||
((= ch ".")
|
||||
(do (flush!) (set! mode "class") (walk (+ i 1))))
|
||||
(do
|
||||
(flush!)
|
||||
(set! mode "class")
|
||||
(walk (+ i 1))))
|
||||
((= ch "#")
|
||||
(do (flush!) (set! mode "id") (walk (+ i 1))))
|
||||
(true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
|
||||
(true
|
||||
(do (set! cur (str cur ch)) (walk (+ i 1)))))))))
|
||||
(walk 0)
|
||||
(flush!)
|
||||
{:tag tag :classes classes :id id}))))
|
||||
@@ -1773,11 +1724,11 @@
|
||||
(value type-name)
|
||||
(if (nil? value) false (hs-type-check value type-name))))
|
||||
|
||||
|
||||
(define
|
||||
hs-strict-eq
|
||||
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
|
||||
|
||||
|
||||
(define
|
||||
hs-id=
|
||||
(fn
|
||||
@@ -1809,20 +1760,6 @@
|
||||
((nil? suffix) false)
|
||||
(true (ends-with? (str s) (str suffix))))))
|
||||
|
||||
(define
|
||||
hs-attr-watch!
|
||||
(fn
|
||||
(target attr-name handler)
|
||||
(let
|
||||
((mo-class (host-get (host-global "window") "MutationObserver")))
|
||||
(when
|
||||
mo-class
|
||||
(let
|
||||
((cb (fn (records observer) (for-each (fn (rec) (when (= (host-get rec "attributeName") attr-name) (handler (host-call target "getAttribute" attr-name)))) records))))
|
||||
(let
|
||||
((mo (host-new "MutationObserver" cb)))
|
||||
(host-call mo "observe" target {:attributeFilter (list attr-name) :attributes true})))))))
|
||||
|
||||
(define
|
||||
hs-scoped-set!
|
||||
(fn
|
||||
@@ -1868,7 +1805,10 @@
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((pos (host-call a "compareDocumentPosition" b)))
|
||||
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
|
||||
(if
|
||||
(number? pos)
|
||||
(not (= 0 (mod (/ pos 4) 2)))
|
||||
false)))
|
||||
(true (< (str a) (str b))))))
|
||||
|
||||
(define
|
||||
@@ -1989,7 +1929,10 @@
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((pos (host-call a "compareDocumentPosition" b)))
|
||||
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
|
||||
(if
|
||||
(number? pos)
|
||||
(not (= 0 (mod (/ pos 4) 2)))
|
||||
false)))
|
||||
(true (< (str a) (str b))))))
|
||||
|
||||
(define
|
||||
@@ -2042,7 +1985,9 @@
|
||||
|
||||
(define
|
||||
hs-morph-char
|
||||
(fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
|
||||
(fn
|
||||
(s p)
|
||||
(if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
|
||||
|
||||
(define
|
||||
hs-morph-index-from
|
||||
@@ -2070,7 +2015,10 @@
|
||||
(q)
|
||||
(let
|
||||
((c (hs-morph-char s q)))
|
||||
(if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
|
||||
(if
|
||||
(and c (< (index-of stop c) 0))
|
||||
(loop (+ q 1))
|
||||
q))))
|
||||
(let ((e (loop p))) (list (substring s p e) e))))
|
||||
|
||||
(define
|
||||
@@ -2112,7 +2060,9 @@
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list name (substring s (+ p4 1) close)))))))
|
||||
(list
|
||||
name
|
||||
(substring s (+ p4 1) close)))))))
|
||||
((= c2 "'")
|
||||
(let
|
||||
((close (hs-morph-index-from s "'" (+ p4 1))))
|
||||
@@ -2122,7 +2072,9 @@
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list name (substring s (+ p4 1) close)))))))
|
||||
(list
|
||||
name
|
||||
(substring s (+ p4 1) close)))))))
|
||||
(true
|
||||
(let
|
||||
((r2 (hs-morph-read-until s p4 " \t\n/>")))
|
||||
@@ -2206,7 +2158,9 @@
|
||||
(for-each
|
||||
(fn
|
||||
(c)
|
||||
(when (> (string-length c) 0) (dom-add-class el c)))
|
||||
(when
|
||||
(> (string-length c) 0)
|
||||
(dom-add-class el c)))
|
||||
(split v " ")))
|
||||
((and keep-id (= n "id")) nil)
|
||||
(true (dom-set-attr el n v)))))
|
||||
@@ -2307,7 +2261,8 @@
|
||||
((parts (split resolved ":")))
|
||||
(let
|
||||
((prop (first parts))
|
||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(val
|
||||
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(cond
|
||||
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
|
||||
(let
|
||||
@@ -2347,7 +2302,8 @@
|
||||
((parts (split resolved ":")))
|
||||
(let
|
||||
((prop (first parts))
|
||||
(val (if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(val
|
||||
(if (> (len parts) 1) (nth parts 1) nil)))
|
||||
(cond
|
||||
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
|
||||
(let
|
||||
@@ -2452,10 +2408,14 @@
|
||||
(if
|
||||
(= depth 1)
|
||||
j
|
||||
(find-close (+ j 1) (- depth 1)))
|
||||
(find-close
|
||||
(+ j 1)
|
||||
(- depth 1)))
|
||||
(if
|
||||
(= (nth raw j) "{")
|
||||
(find-close (+ j 1) (+ depth 1))
|
||||
(find-close
|
||||
(+ j 1)
|
||||
(+ depth 1))
|
||||
(find-close (+ j 1) depth))))))
|
||||
(let
|
||||
((close (find-close start 1)))
|
||||
@@ -2566,7 +2526,10 @@
|
||||
(if
|
||||
(= (len lst) 0)
|
||||
-1
|
||||
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
|
||||
(if
|
||||
(= (first lst) item)
|
||||
i
|
||||
(idx-loop (rest lst) (+ i 1))))))
|
||||
(idx-loop obj 0)))
|
||||
(true
|
||||
(let
|
||||
@@ -2658,7 +2621,8 @@
|
||||
(cond
|
||||
((= end "hs-pick-end") n)
|
||||
((= end "hs-pick-start") 0)
|
||||
((and (number? end) (< end 0)) (max 0 (+ n end)))
|
||||
((and (number? end) (< end 0))
|
||||
(max 0 (+ n end)))
|
||||
(true end))))
|
||||
(cond
|
||||
((string? col) (slice col s e))
|
||||
@@ -2838,8 +2802,6 @@
|
||||
hs-sorted-by-desc
|
||||
(fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
|
||||
|
||||
;; ── SourceInfo API ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
hs-dom-has-var?
|
||||
(fn
|
||||
@@ -2859,6 +2821,8 @@
|
||||
((store (host-get el "__hs_vars")))
|
||||
(if (nil? store) nil (host-get store name)))))
|
||||
|
||||
;; ── SourceInfo API ────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
hs-dom-set-var-raw!
|
||||
(fn
|
||||
@@ -2949,12 +2913,7 @@
|
||||
|
||||
(define
|
||||
hs-null-error!
|
||||
(fn
|
||||
(selector)
|
||||
(let
|
||||
((msg (str "'" selector "' is null")))
|
||||
(host-set! (host-global "window") "_hs_null_error" msg)
|
||||
(guard (_null-e (true nil)) (raise msg)))))
|
||||
(fn (selector) (raise (str "'" selector "' is null"))))
|
||||
|
||||
(define
|
||||
hs-named-target
|
||||
@@ -2974,7 +2933,9 @@
|
||||
((results (hs-query-all selector)))
|
||||
(if
|
||||
(and
|
||||
(or (nil? results) (and (list? results) (= (len results) 0)))
|
||||
(or
|
||||
(nil? results)
|
||||
(and (list? results) (= (len results) 0)))
|
||||
(string? selector)
|
||||
(> (len selector) 0)
|
||||
(= (substring selector 0 1) "#"))
|
||||
|
||||
@@ -855,230 +855,4 @@
|
||||
:else (do (t-advance! 1) (scan-template!)))))))
|
||||
(scan-template!)
|
||||
(t-emit! "eof" nil)
|
||||
tokens)))
|
||||
|
||||
;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
|
||||
;;
|
||||
;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
|
||||
;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
|
||||
;; flat list; the stream wrapper adds the stateful operations.
|
||||
;;
|
||||
;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
|
||||
|
||||
(define
|
||||
hs-stream-type-map
|
||||
(fn
|
||||
(t)
|
||||
(cond
|
||||
((= t "ident") "IDENTIFIER")
|
||||
((= t "number") "NUMBER")
|
||||
((= t "string") "STRING")
|
||||
((= t "class") "CLASS_REF")
|
||||
((= t "id") "ID_REF")
|
||||
((= t "attr") "ATTRIBUTE_REF")
|
||||
((= t "style") "STYLE_REF")
|
||||
((= t "whitespace") "WHITESPACE")
|
||||
((= t "op") "OPERATOR")
|
||||
((= t "eof") "EOF")
|
||||
(true (upcase t)))))
|
||||
|
||||
;; Create a stream from a source string.
|
||||
;; Returns a dict — mutable via dict-set!.
|
||||
(define
|
||||
hs-stream
|
||||
(fn
|
||||
(src)
|
||||
{:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
|
||||
|
||||
;; Skip whitespace tokens, advancing pos to the next non-WS token.
|
||||
;; Captures the last skipped whitespace value into :last-ws.
|
||||
(define
|
||||
hs-stream-skip-ws!
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(when
|
||||
(and (< p (len tokens))
|
||||
(= (get (nth tokens p) :type) "whitespace"))
|
||||
(do
|
||||
(dict-set! s :last-ws (get (nth tokens p) :value))
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop))))))
|
||||
(loop))))
|
||||
|
||||
;; Current token (after skipping whitespace).
|
||||
(define
|
||||
hs-stream-current
|
||||
(fn
|
||||
(s)
|
||||
(do
|
||||
(hs-stream-skip-ws! s)
|
||||
(let
|
||||
((tokens (get s :tokens)) (p (get s :pos)))
|
||||
(if (< p (len tokens)) (nth tokens p) nil)))))
|
||||
|
||||
;; Returns the current token if its value matches; advances and updates
|
||||
;; :last-match. Returns nil otherwise (no advance).
|
||||
;; Honors the follow set: tokens whose value is in :follows do NOT match.
|
||||
(define
|
||||
hs-stream-match
|
||||
(fn
|
||||
(s value)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (f) (= f value)) (get s :follows)) nil)
|
||||
((= (get cur :value) value)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match by upstream-style type name. Accepts any number of allowed types.
|
||||
(define
|
||||
hs-stream-match-type
|
||||
(fn
|
||||
(s &rest types)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match if value is one of the given names.
|
||||
(define
|
||||
hs-stream-match-any
|
||||
(fn
|
||||
(s &rest names)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((some (fn (n) (= (get cur :value) n)) names)
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Match an op token whose value is in the list.
|
||||
(define
|
||||
hs-stream-match-any-op
|
||||
(fn
|
||||
(s &rest ops)
|
||||
(let
|
||||
((cur (hs-stream-current s)))
|
||||
(cond
|
||||
((nil? cur) nil)
|
||||
((and (= (get cur :type) "op")
|
||||
(some (fn (o) (= (get cur :value) o)) ops))
|
||||
(do
|
||||
(dict-set! s :pos (+ (get s :pos) 1))
|
||||
(dict-set! s :last-match cur)
|
||||
cur))
|
||||
(true nil)))))
|
||||
|
||||
;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
|
||||
(define
|
||||
hs-stream-peek
|
||||
(fn
|
||||
(s value offset)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
skip-n-non-ws
|
||||
(fn
|
||||
(p remaining)
|
||||
(cond
|
||||
((>= p (len tokens)) -1)
|
||||
((= (get (nth tokens p) :type) "whitespace")
|
||||
(skip-n-non-ws (+ p 1) remaining))
|
||||
((= remaining 0) p)
|
||||
(true (skip-n-non-ws (+ p 1) (- remaining 1))))))
|
||||
(let
|
||||
((p (skip-n-non-ws (get s :pos) offset)))
|
||||
(if (and (>= p 0) (< p (len tokens))
|
||||
(= (get (nth tokens p) :value) value))
|
||||
(nth tokens p)
|
||||
nil)))))
|
||||
|
||||
;; Consume tokens until one whose value matches the marker. Returns
|
||||
;; the consumed list (excluding the marker). Marker becomes current.
|
||||
(define
|
||||
hs-stream-consume-until
|
||||
(fn
|
||||
(s marker)
|
||||
(let
|
||||
((tokens (get s :tokens)) (out (list)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(acc)
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(cond
|
||||
((>= p (len tokens)) acc)
|
||||
((= (get (nth tokens p) :value) marker) acc)
|
||||
(true
|
||||
(do
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop (append acc (list (nth tokens p))))))))))
|
||||
(loop out))))
|
||||
|
||||
;; Consume until the next whitespace token; returns the consumed list.
|
||||
(define
|
||||
hs-stream-consume-until-ws
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((tokens (get s :tokens)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(acc)
|
||||
(let
|
||||
((p (get s :pos)))
|
||||
(cond
|
||||
((>= p (len tokens)) acc)
|
||||
((= (get (nth tokens p) :type) "whitespace") acc)
|
||||
(true
|
||||
(do
|
||||
(dict-set! s :pos (+ p 1))
|
||||
(loop (append acc (list (nth tokens p))))))))))
|
||||
(loop (list)))))
|
||||
|
||||
;; Follow-set management.
|
||||
(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
|
||||
(define
|
||||
hs-stream-pop-follow!
|
||||
(fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
|
||||
(define
|
||||
hs-stream-push-follows!
|
||||
(fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
|
||||
(define
|
||||
hs-stream-pop-follows!
|
||||
(fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
|
||||
(define
|
||||
hs-stream-clear-follows!
|
||||
(fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
|
||||
(define
|
||||
hs-stream-restore-follows!
|
||||
(fn (s saved) (dict-set! s :follows saved)))
|
||||
|
||||
;; Last-consumed token / whitespace.
|
||||
(define hs-stream-last-match (fn (s) (get s :last-match)))
|
||||
(define hs-stream-last-ws (fn (s) (get s :last-ws)))
|
||||
tokens)))
|
||||
@@ -1,590 +0,0 @@
|
||||
;; lib/minikanren/clpfd.sx — Phase 6: native CLP(FD) on miniKanren.
|
||||
;;
|
||||
;; The substitution dict carries an extra reserved key "_fd" that holds a
|
||||
;; constraint-store record:
|
||||
;;
|
||||
;; {:domains {var-name -> sorted-int-list}
|
||||
;; :constraints (... pending constraint closures ...)}
|
||||
;;
|
||||
;; Domains are sorted SX lists of ints (no duplicates).
|
||||
;; Constraints are functions s -> s-or-nil that propagate / re-check.
|
||||
;; They are re-fired after every label binding via fd-fire-store.
|
||||
|
||||
(define fd-key "_fd")
|
||||
|
||||
;; --- domain primitives ---
|
||||
|
||||
(define
|
||||
fd-dom-rev
|
||||
(fn
|
||||
(xs acc)
|
||||
(cond
|
||||
((empty? xs) acc)
|
||||
(:else (fd-dom-rev (rest xs) (cons (first xs) acc))))))
|
||||
|
||||
(define
|
||||
fd-dom-insert
|
||||
(fn
|
||||
(x desc)
|
||||
(cond
|
||||
((empty? desc) (list x))
|
||||
((= x (first desc)) desc)
|
||||
((> x (first desc)) (cons x desc))
|
||||
(:else (cons (first desc) (fd-dom-insert x (rest desc)))))))
|
||||
|
||||
(define
|
||||
fd-dom-sort-dedupe
|
||||
(fn
|
||||
(xs acc)
|
||||
(cond
|
||||
((empty? xs) (fd-dom-rev acc (list)))
|
||||
(:else (fd-dom-sort-dedupe (rest xs) (fd-dom-insert (first xs) acc))))))
|
||||
|
||||
(define fd-dom-from-list (fn (xs) (fd-dom-sort-dedupe xs (list))))
|
||||
|
||||
(define fd-dom-empty? (fn (d) (empty? d)))
|
||||
(define
|
||||
fd-dom-singleton?
|
||||
(fn (d) (and (not (empty? d)) (empty? (rest d)))))
|
||||
(define fd-dom-min (fn (d) (first d)))
|
||||
|
||||
(define
|
||||
fd-dom-last
|
||||
(fn
|
||||
(d)
|
||||
(cond ((empty? (rest d)) (first d)) (:else (fd-dom-last (rest d))))))
|
||||
|
||||
(define fd-dom-max (fn (d) (fd-dom-last d)))
|
||||
(define fd-dom-member? (fn (x d) (some (fn (y) (= x y)) d)))
|
||||
|
||||
(define
|
||||
fd-dom-intersect
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((empty? a) (list))
|
||||
((empty? b) (list))
|
||||
((= (first a) (first b))
|
||||
(cons (first a) (fd-dom-intersect (rest a) (rest b))))
|
||||
((< (first a) (first b)) (fd-dom-intersect (rest a) b))
|
||||
(:else (fd-dom-intersect a (rest b))))))
|
||||
|
||||
(define
|
||||
fd-dom-without
|
||||
(fn
|
||||
(x d)
|
||||
(cond
|
||||
((empty? d) (list))
|
||||
((= (first d) x) (rest d))
|
||||
((> (first d) x) d)
|
||||
(:else (cons (first d) (fd-dom-without x (rest d)))))))
|
||||
|
||||
(define
|
||||
fd-dom-range
|
||||
(fn
|
||||
(lo hi)
|
||||
(cond
|
||||
((> lo hi) (list))
|
||||
(:else (cons lo (fd-dom-range (+ lo 1) hi))))))
|
||||
|
||||
;; --- constraint store accessors ---
|
||||
|
||||
(define fd-store-empty (fn () {:domains {} :constraints (list)}))
|
||||
|
||||
(define
|
||||
fd-store-of
|
||||
(fn
|
||||
(s)
|
||||
(cond ((has-key? s fd-key) (get s fd-key)) (:else (fd-store-empty)))))
|
||||
|
||||
(define fd-domains-of (fn (s) (get (fd-store-of s) :domains)))
|
||||
(define fd-with-store (fn (s store) (assoc s fd-key store)))
|
||||
|
||||
(define
|
||||
fd-domain-of
|
||||
(fn
|
||||
(s var-name)
|
||||
(let
|
||||
((doms (fd-domains-of s)))
|
||||
(cond ((has-key? doms var-name) (get doms var-name)) (:else nil)))))
|
||||
|
||||
(define
|
||||
fd-set-domain
|
||||
(fn
|
||||
(s var-name d)
|
||||
(cond
|
||||
((fd-dom-empty? d) nil)
|
||||
(:else
|
||||
(let
|
||||
((store (fd-store-of s)))
|
||||
(let
|
||||
((doms-prime (assoc (get store :domains) var-name d)))
|
||||
(let
|
||||
((store-prime (assoc store :domains doms-prime)))
|
||||
(fd-with-store s store-prime))))))))
|
||||
|
||||
(define
|
||||
fd-add-constraint
|
||||
(fn
|
||||
(s c)
|
||||
(let
|
||||
((store (fd-store-of s)))
|
||||
(let
|
||||
((cs-prime (cons c (get store :constraints))))
|
||||
(let
|
||||
((store-prime (assoc store :constraints cs-prime)))
|
||||
(fd-with-store s store-prime))))))
|
||||
|
||||
(define
|
||||
fd-fire-list
|
||||
(fn
|
||||
(cs s)
|
||||
(cond
|
||||
((empty? cs) s)
|
||||
(:else
|
||||
(let
|
||||
((s2 ((first cs) s)))
|
||||
(cond ((= s2 nil) nil) (:else (fd-fire-list (rest cs) s2))))))))
|
||||
|
||||
(define
|
||||
fd-store-signature
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((doms (fd-domains-of s)))
|
||||
(let
|
||||
((dom-sizes (reduce (fn (acc k) (+ acc (len (get doms k)))) 0 (keys doms))))
|
||||
(+ dom-sizes (len (keys s)))))))
|
||||
|
||||
(define
|
||||
fd-fire-store
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((s2 (fd-fire-list (get (fd-store-of s) :constraints) s)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
((= (fd-store-signature s) (fd-store-signature s2)) s2)
|
||||
(:else (fd-fire-store s2))))))
|
||||
|
||||
;; --- user-facing goals ---
|
||||
|
||||
(define
|
||||
fd-in
|
||||
(fn
|
||||
(x dom-list)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((new-dom (fd-dom-from-list dom-list)))
|
||||
(let
|
||||
((wx (mk-walk x s)))
|
||||
(cond
|
||||
((number? wx)
|
||||
(cond ((fd-dom-member? wx new-dom) (unit s)) (:else mzero)))
|
||||
((is-var? wx)
|
||||
(let
|
||||
((existing (fd-domain-of s (var-name wx))))
|
||||
(let
|
||||
((narrowed (cond ((= existing nil) new-dom) (:else (fd-dom-intersect existing new-dom)))))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) narrowed)))
|
||||
(cond ((= s2 nil) mzero) (:else (unit s2)))))))
|
||||
(:else mzero)))))))
|
||||
|
||||
;; --- fd-neq ---
|
||||
|
||||
(define
|
||||
fd-neq-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((= wx wy) nil) (:else s)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((y-dom (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= y-dom nil) s)
|
||||
(:else
|
||||
(fd-set-domain s (var-name wy) (fd-dom-without wx y-dom))))))
|
||||
((and (number? wy) (is-var? wx))
|
||||
(let
|
||||
((x-dom (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= x-dom nil) s)
|
||||
(:else
|
||||
(fd-set-domain s (var-name wx) (fd-dom-without wy x-dom))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-neq
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (s-prime) (fd-neq-prop x y s-prime))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-lt ---
|
||||
|
||||
(define
|
||||
fd-lt-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((< wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= yd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wy)
|
||||
(filter (fn (v) (> v wx)) yd))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= xd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wx)
|
||||
(filter (fn (v) (< v wy)) xd))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((or (= xd nil) (= yd nil)) s)
|
||||
(:else
|
||||
(let
|
||||
((xd-prime (filter (fn (v) (< v (fd-dom-max yd))) xd)))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) xd-prime)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((yd-prime (filter (fn (v) (> v (fd-dom-min xd-prime))) yd)))
|
||||
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-lt
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-lt-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-lte ---
|
||||
|
||||
(define
|
||||
fd-lte-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((<= wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((= yd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wy)
|
||||
(filter (fn (v) (>= v wx)) yd))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= xd nil) s)
|
||||
(:else
|
||||
(fd-set-domain
|
||||
s
|
||||
(var-name wx)
|
||||
(filter (fn (v) (<= v wy)) xd))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((or (= xd nil) (= yd nil)) s)
|
||||
(:else
|
||||
(let
|
||||
((xd-prime (filter (fn (v) (<= v (fd-dom-max yd))) xd)))
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) xd-prime)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((yd-prime (filter (fn (v) (>= v (fd-dom-min xd-prime))) yd)))
|
||||
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-lte
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-lte-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-eq ---
|
||||
|
||||
(define
|
||||
fd-eq-prop
|
||||
(fn
|
||||
(x y s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy))
|
||||
(cond ((= wx wy) s) (:else nil)))
|
||||
((and (number? wx) (is-var? wy))
|
||||
(let
|
||||
((yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((and (not (= yd nil)) (not (fd-dom-member? wx yd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify wy wx s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
((and (is-var? wx) (number? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((and (not (= xd nil)) (not (fd-dom-member? wy xd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify wx wy s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
((and (is-var? wx) (is-var? wy))
|
||||
(let
|
||||
((xd (fd-domain-of s (var-name wx)))
|
||||
(yd (fd-domain-of s (var-name wy))))
|
||||
(cond
|
||||
((and (= xd nil) (= yd nil))
|
||||
(let
|
||||
((s2 (mk-unify wx wy s)))
|
||||
(cond ((= s2 nil) nil) (:else s2))))
|
||||
(:else
|
||||
(let
|
||||
((shared (cond ((= xd nil) yd) ((= yd nil) xd) (:else (fd-dom-intersect xd yd)))))
|
||||
(cond
|
||||
((fd-dom-empty? shared) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (fd-set-domain s (var-name wx) shared)))
|
||||
(cond
|
||||
((= s2 nil) nil)
|
||||
(:else
|
||||
(let
|
||||
((s3 (fd-set-domain s2 (var-name wy) shared)))
|
||||
(cond
|
||||
((= s3 nil) nil)
|
||||
(:else (mk-unify wx wy s3))))))))))))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-eq
|
||||
(fn
|
||||
(x y)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-eq-prop x y sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- labelling ---
|
||||
|
||||
(define
|
||||
fd-try-each-value
|
||||
(fn
|
||||
(x dom s)
|
||||
(cond
|
||||
((empty? dom) mzero)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify x (first dom) s)))
|
||||
(let
|
||||
((s3 (cond ((= s2 nil) nil) (:else (fd-fire-store s2)))))
|
||||
(let
|
||||
((this-stream (cond ((= s3 nil) mzero) (:else (unit s3))))
|
||||
(rest-stream (fd-try-each-value x (rest dom) s)))
|
||||
(mk-mplus this-stream rest-stream))))))))
|
||||
|
||||
(define
|
||||
fd-label-one
|
||||
(fn
|
||||
(x)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((wx (mk-walk x s)))
|
||||
(cond
|
||||
((number? wx) (unit s))
|
||||
((is-var? wx)
|
||||
(let
|
||||
((dom (fd-domain-of s (var-name wx))))
|
||||
(cond
|
||||
((= dom nil) mzero)
|
||||
(:else (fd-try-each-value wx dom s)))))
|
||||
(:else mzero))))))
|
||||
|
||||
(define
|
||||
fd-label
|
||||
(fn
|
||||
(vars)
|
||||
(cond
|
||||
((empty? vars) succeed)
|
||||
(:else (mk-conj (fd-label-one (first vars)) (fd-label (rest vars)))))))
|
||||
|
||||
;; --- fd-distinct (pairwise distinct via fd-neq) ---
|
||||
|
||||
(define
|
||||
fd-distinct-from-head
|
||||
(fn
|
||||
(x others)
|
||||
(cond
|
||||
((empty? others) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(fd-neq x (first others))
|
||||
(fd-distinct-from-head x (rest others)))))))
|
||||
|
||||
(define
|
||||
fd-distinct
|
||||
(fn
|
||||
(vars)
|
||||
(cond
|
||||
((empty? vars) succeed)
|
||||
((empty? (rest vars)) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(fd-distinct-from-head (first vars) (rest vars))
|
||||
(fd-distinct (rest vars)))))))
|
||||
|
||||
;; --- fd-plus (x + y = z, ground-cases propagator) ---
|
||||
|
||||
(define
|
||||
fd-bind-or-narrow
|
||||
(fn
|
||||
(w target s)
|
||||
(cond
|
||||
((number? w) (cond ((= w target) s) (:else nil)))
|
||||
((is-var? w)
|
||||
(let
|
||||
((wd (fd-domain-of s (var-name w))))
|
||||
(cond
|
||||
((and (not (= wd nil)) (not (fd-dom-member? target wd))) nil)
|
||||
(:else
|
||||
(let
|
||||
((s2 (mk-unify w target s)))
|
||||
(cond ((= s2 nil) nil) (:else s2)))))))
|
||||
(:else nil))))
|
||||
|
||||
(define
|
||||
fd-plus-prop
|
||||
(fn
|
||||
(x y z s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy) (number? wz))
|
||||
(cond ((= (+ wx wy) wz) s) (:else nil)))
|
||||
((and (number? wx) (number? wy))
|
||||
(fd-bind-or-narrow wz (+ wx wy) s))
|
||||
((and (number? wx) (number? wz))
|
||||
(fd-bind-or-narrow wy (- wz wx) s))
|
||||
((and (number? wy) (number? wz))
|
||||
(fd-bind-or-narrow wx (- wz wy) s))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-plus
|
||||
(fn
|
||||
(x y z)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-plus-prop x y z sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
|
||||
;; --- fd-times (x * y = z, ground-cases propagator) ---
|
||||
|
||||
(define
|
||||
fd-times-prop
|
||||
(fn
|
||||
(x y z s)
|
||||
(let
|
||||
((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
|
||||
(cond
|
||||
((and (number? wx) (number? wy) (number? wz))
|
||||
(cond ((= (* wx wy) wz) s) (:else nil)))
|
||||
((and (number? wx) (number? wy))
|
||||
(fd-bind-or-narrow wz (* wx wy) s))
|
||||
((and (number? wx) (number? wz))
|
||||
(cond
|
||||
((= wx 0) (cond ((= wz 0) s) (:else nil)))
|
||||
((not (= (mod wz wx) 0)) nil)
|
||||
(:else (fd-bind-or-narrow wy (/ wz wx) s))))
|
||||
((and (number? wy) (number? wz))
|
||||
(cond
|
||||
((= wy 0) (cond ((= wz 0) s) (:else nil)))
|
||||
((not (= (mod wz wy) 0)) nil)
|
||||
(:else (fd-bind-or-narrow wx (/ wz wy) s))))
|
||||
(:else s)))))
|
||||
|
||||
(define
|
||||
fd-times
|
||||
(fn
|
||||
(x y z)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((c (fn (sp) (fd-times-prop x y z sp))))
|
||||
(let
|
||||
((s2 (fd-add-constraint s c)))
|
||||
(let
|
||||
((s3 (c s2)))
|
||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||
@@ -1,42 +0,0 @@
|
||||
;; lib/minikanren/conda.sx — Phase 5 piece A: `conda`, the soft-cut.
|
||||
;;
|
||||
;; (conda (g0 g ...) (h0 h ...) ...)
|
||||
;; — first clause whose head g0 produces ANY answer wins; ALL of g0's
|
||||
;; answers are then conj'd with the rest of that clause; later
|
||||
;; clauses are NOT tried.
|
||||
;; — differs from condu only in not wrapping g0 in onceo: condu
|
||||
;; commits to the SINGLE first answer, conda lets the head's full
|
||||
;; answer-set flow into the rest of the clause.
|
||||
;; (Reasoned Schemer chapter 10; Byrd 5.3.)
|
||||
|
||||
(define
|
||||
conda-try
|
||||
(fn
|
||||
(clauses s)
|
||||
(cond
|
||||
((empty? clauses) mzero)
|
||||
(:else
|
||||
(let
|
||||
((cl (first clauses)))
|
||||
(let
|
||||
((head-goal (first cl)) (rest-goals (rest cl)))
|
||||
(let
|
||||
((peek (stream-take 1 (head-goal s))))
|
||||
(if
|
||||
(empty? peek)
|
||||
(conda-try (rest clauses) s)
|
||||
(mk-bind (head-goal s) (mk-conj-list rest-goals))))))))))
|
||||
|
||||
(defmacro
|
||||
conda
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(fn
|
||||
(s)
|
||||
(conda-try
|
||||
(list
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn (cl) (quasiquote (list (splice-unquote cl))))
|
||||
clauses)))
|
||||
s))))
|
||||
@@ -1,39 +0,0 @@
|
||||
;; lib/minikanren/conde.sx — Phase 2 piece C: `conde`, the canonical
|
||||
;; miniKanren and-or form, with implicit Zzz inverse-eta delay so recursive
|
||||
;; relations like appendo terminate.
|
||||
;;
|
||||
;; (conde (g1a g1b ...) (g2a g2b ...) ...)
|
||||
;; ≡ (mk-disj (Zzz (mk-conj g1a g1b ...))
|
||||
;; (Zzz (mk-conj g2a g2b ...)) ...)
|
||||
;;
|
||||
;; `Zzz g` wraps a goal expression in (fn (S) (fn () (g S))) so that
|
||||
;; `g`'s body isn't constructed until the surrounding fn is applied to a
|
||||
;; substitution AND the returned thunk is forced. This is what gives
|
||||
;; miniKanren its laziness — recursive goal definitions can be `(conde
|
||||
;; ... (... (recur ...)))` without infinite descent at construction time.
|
||||
;;
|
||||
;; Hygiene: the substitution parameter is gensym'd so that user goal
|
||||
;; expressions which themselves bind `s` (e.g. `(appendo l s ls)`) keep
|
||||
;; their lexical `s` and don't accidentally reference the wrapper's
|
||||
;; substitution. Without gensym, miniKanren relations that follow the
|
||||
;; common (l s ls) parameter convention are silently miscompiled.
|
||||
|
||||
(defmacro
|
||||
Zzz
|
||||
(g)
|
||||
(let
|
||||
((s-sym (gensym "zzz-s-")))
|
||||
(quasiquote
|
||||
(fn ((unquote s-sym)) (fn () ((unquote g) (unquote s-sym)))))))
|
||||
|
||||
(defmacro
|
||||
conde
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(mk-disj
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn
|
||||
(clause)
|
||||
(quasiquote (Zzz (mk-conj (splice-unquote clause)))))
|
||||
clauses)))))
|
||||
@@ -1,58 +0,0 @@
|
||||
;; lib/minikanren/condu.sx — Phase 2 piece D: `condu` and `onceo`.
|
||||
;;
|
||||
;; Both are commitment forms (no backtracking into discarded options):
|
||||
;;
|
||||
;; (onceo g) — succeeds at most once: takes the first answer
|
||||
;; stream-take produces from (g s).
|
||||
;;
|
||||
;; (condu (g0 g ...) (h0 h ...) ...)
|
||||
;; — first clause whose head goal succeeds wins; only
|
||||
;; the first answer of the head is propagated to the
|
||||
;; rest of that clause; later clauses are not tried.
|
||||
;; (Reasoned Schemer chapter 10; Byrd 5.4.)
|
||||
|
||||
(define
|
||||
onceo
|
||||
(fn
|
||||
(g)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((peek (stream-take 1 (g s))))
|
||||
(if (empty? peek) mzero (unit (first peek)))))))
|
||||
|
||||
;; condu-try — runtime walker over a list of clauses (each clause a list of
|
||||
;; goals). Forces the head with stream-take 1; if head fails, recurse to
|
||||
;; the next clause; if head succeeds, commits its single answer through
|
||||
;; the rest of the clause.
|
||||
(define
|
||||
condu-try
|
||||
(fn
|
||||
(clauses s)
|
||||
(cond
|
||||
((empty? clauses) mzero)
|
||||
(:else
|
||||
(let
|
||||
((cl (first clauses)))
|
||||
(let
|
||||
((head-goal (first cl)) (rest-goals (rest cl)))
|
||||
(let
|
||||
((peek (stream-take 1 (head-goal s))))
|
||||
(if
|
||||
(empty? peek)
|
||||
(condu-try (rest clauses) s)
|
||||
((mk-conj-list rest-goals) (first peek))))))))))
|
||||
|
||||
(defmacro
|
||||
condu
|
||||
(&rest clauses)
|
||||
(quasiquote
|
||||
(fn
|
||||
(s)
|
||||
(condu-try
|
||||
(list
|
||||
(splice-unquote
|
||||
(map
|
||||
(fn (cl) (quasiquote (list (splice-unquote cl))))
|
||||
clauses)))
|
||||
s))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/defrel.sx — Prolog-style defrel macro.
|
||||
;;
|
||||
;; (defrel (NAME ARG1 ARG2 ...)
|
||||
;; (CLAUSE1 ...)
|
||||
;; (CLAUSE2 ...)
|
||||
;; ...)
|
||||
;;
|
||||
;; expands to
|
||||
;;
|
||||
;; (define NAME (fn (ARG1 ARG2 ...) (conde (CLAUSE1 ...) (CLAUSE2 ...))))
|
||||
;;
|
||||
;; This puts each clause's goals immediately after the head, mirroring
|
||||
;; Prolog's `name(Args) :- goals.` shape. Clauses are conde-conjoined
|
||||
;; goals — `Zzz`-wrapping is automatic via `conde`, so recursive
|
||||
;; relations terminate on partial answers.
|
||||
|
||||
(defmacro
|
||||
defrel
|
||||
(head &rest clauses)
|
||||
(let
|
||||
((name (first head)) (args (rest head)))
|
||||
(list
|
||||
(quote define)
|
||||
name
|
||||
(list (quote fn) args (cons (quote conde) clauses)))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/fd.sx — Phase 6 piece A: minimal finite-domain helpers.
|
||||
;;
|
||||
;; A full CLP(FD) engine (arc consistency, native integer domains, fd-plus
|
||||
;; etc.) is Phase 6 proper. For now we expose two small relations layered
|
||||
;; on the existing list machinery — they're sufficient for permutation
|
||||
;; puzzles, the N-queens-style core of constraint solving:
|
||||
;;
|
||||
;; (ino x dom) — x is a member of dom (alias for membero with the
|
||||
;; constraint-store-friendly argument order).
|
||||
;; (all-distincto l) — all elements of l are pairwise distinct.
|
||||
;;
|
||||
;; all-distincto uses nafc + membero on the tail — it requires the head
|
||||
;; element of each recursive step to be ground enough for membero to be
|
||||
;; finitary, so order matters: prefer (in x dom) goals BEFORE
|
||||
;; (all-distincto (list x ...)) so values get committed first.
|
||||
|
||||
(define ino (fn (x dom) (membero x dom)))
|
||||
|
||||
(define
|
||||
all-distincto
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (nafc (membero a d)) (all-distincto d))))))
|
||||
@@ -1,23 +0,0 @@
|
||||
;; lib/minikanren/fresh.sx — Phase 2 piece B: `fresh` for introducing
|
||||
;; logic variables inside a goal body.
|
||||
;;
|
||||
;; (fresh (x y z) goal1 goal2 ...)
|
||||
;; ≡ (let ((x (make-var)) (y (make-var)) (z (make-var)))
|
||||
;; (mk-conj goal1 goal2 ...))
|
||||
;;
|
||||
;; A macro rather than a function so user-named vars are real lexical
|
||||
;; bindings — which is also what miniKanren convention expects.
|
||||
;; The empty-vars form (fresh () goal ...) is just a goal grouping.
|
||||
|
||||
(defmacro
|
||||
fresh
|
||||
(vars &rest goals)
|
||||
(quasiquote
|
||||
(let
|
||||
(unquote (map (fn (v) (list v (list (quote make-var)))) vars))
|
||||
(mk-conj (splice-unquote goals)))))
|
||||
|
||||
;; call-fresh — functional alternative for code that builds goals
|
||||
;; programmatically:
|
||||
;; ((call-fresh (fn (x) (== x 7))) empty-s) → ({:_.N 7})
|
||||
(define call-fresh (fn (f) (fn (s) ((f (make-var)) s))))
|
||||
@@ -1,58 +0,0 @@
|
||||
;; lib/minikanren/goals.sx — Phase 2 piece B: core goals.
|
||||
;;
|
||||
;; A goal is a function (fn (s) → stream-of-substitutions).
|
||||
;; Goals built here:
|
||||
;; succeed — always returns (unit s)
|
||||
;; fail — always returns mzero
|
||||
;; == — unifies two terms; succeeds with a singleton, else fails
|
||||
;; ==-check — opt-in occurs-checked equality
|
||||
;; conj2 / mk-conj — sequential conjunction of goals
|
||||
;; disj2 / mk-disj — interleaved disjunction of goals (raw — `conde` adds
|
||||
;; the implicit-conj-per-clause sugar in a later commit)
|
||||
|
||||
(define succeed (fn (s) (unit s)))
|
||||
|
||||
(define fail (fn (s) mzero))
|
||||
|
||||
(define
|
||||
==
|
||||
(fn
|
||||
(u v)
|
||||
(fn
|
||||
(s)
|
||||
(let ((s2 (mk-unify u v s))) (if (= s2 nil) mzero (unit s2))))))
|
||||
|
||||
(define
|
||||
==-check
|
||||
(fn
|
||||
(u v)
|
||||
(fn
|
||||
(s)
|
||||
(let ((s2 (mk-unify-check u v s))) (if (= s2 nil) mzero (unit s2))))))
|
||||
|
||||
(define conj2 (fn (g1 g2) (fn (s) (mk-bind (g1 s) g2))))
|
||||
|
||||
(define disj2 (fn (g1 g2) (fn (s) (mk-mplus (g1 s) (g2 s)))))
|
||||
|
||||
;; Fold goals in a list. (mk-conj-list ()) ≡ succeed; (mk-disj-list ()) ≡ fail.
|
||||
(define
|
||||
mk-conj-list
|
||||
(fn
|
||||
(gs)
|
||||
(cond
|
||||
((empty? gs) succeed)
|
||||
((empty? (rest gs)) (first gs))
|
||||
(:else (conj2 (first gs) (mk-conj-list (rest gs)))))))
|
||||
|
||||
(define
|
||||
mk-disj-list
|
||||
(fn
|
||||
(gs)
|
||||
(cond
|
||||
((empty? gs) fail)
|
||||
((empty? (rest gs)) (first gs))
|
||||
(:else (disj2 (first gs) (mk-disj-list (rest gs)))))))
|
||||
|
||||
(define mk-conj (fn (&rest gs) (mk-conj-list gs)))
|
||||
|
||||
(define mk-disj (fn (&rest gs) (mk-disj-list gs)))
|
||||
@@ -1,151 +0,0 @@
|
||||
;; lib/minikanren/intarith.sx — fast integer arithmetic via project.
|
||||
;;
|
||||
;; These are ground-only escapes into host arithmetic. They run at native
|
||||
;; speed (host ints) but require their arguments to walk to actual numbers
|
||||
;; — they are not relational the way `pluso` (Peano) is. Use them when
|
||||
;; the puzzle size makes Peano impractical.
|
||||
;;
|
||||
;; Naming: `-i` suffix marks "integer-only" goals.
|
||||
|
||||
(define
|
||||
pluso-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (+ a b)) fail))))
|
||||
|
||||
(define
|
||||
minuso-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (- a b)) fail))))
|
||||
|
||||
(define
|
||||
*o-i
|
||||
(fn
|
||||
(a b c)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (number? b)) (== c (* a b)) fail))))
|
||||
|
||||
(define
|
||||
lto-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (< a b))) succeed fail))))
|
||||
|
||||
(define
|
||||
lteo-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (<= a b))) succeed fail))))
|
||||
|
||||
(define
|
||||
neqo-i
|
||||
(fn
|
||||
(a b)
|
||||
(project
|
||||
(a b)
|
||||
(if (and (number? a) (and (number? b) (not (= a b)))) succeed fail))))
|
||||
|
||||
(define numbero (fn (x) (project (x) (if (number? x) succeed fail))))
|
||||
|
||||
(define stringo (fn (x) (project (x) (if (string? x) succeed fail))))
|
||||
|
||||
(define symbolo (fn (x) (project (x) (if (symbol? x) succeed fail))))
|
||||
|
||||
(define
|
||||
even-i
|
||||
(fn (n) (project (n) (if (and (number? n) (even? n)) succeed fail))))
|
||||
|
||||
(define
|
||||
odd-i
|
||||
(fn (n) (project (n) (if (and (number? n) (odd? n)) succeed fail))))
|
||||
|
||||
(define
|
||||
sortedo
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a) (== l (list a))))
|
||||
((fresh (a b rest mid) (conso a mid l) (conso b rest mid) (lteo-i a b) (sortedo mid))))))
|
||||
|
||||
(define
|
||||
mino
|
||||
(fn
|
||||
(l m)
|
||||
(conde
|
||||
((fresh (a) (== l (list a)) (== m a)))
|
||||
((fresh (a d rest-min) (conso a d l) (mino d rest-min) (conde ((lteo-i a rest-min) (== m a)) ((lto-i rest-min a) (== m rest-min))))))))
|
||||
|
||||
(define
|
||||
maxo
|
||||
(fn
|
||||
(l m)
|
||||
(conde
|
||||
((fresh (a) (== l (list a)) (== m a)))
|
||||
((fresh (a d rest-max) (conso a d l) (maxo d rest-max) (conde ((lteo-i rest-max a) (== m a)) ((lto-i a rest-max) (== m rest-max))))))))
|
||||
|
||||
(define
|
||||
sumo
|
||||
(fn
|
||||
(l total)
|
||||
(conde
|
||||
((nullo l) (== total 0))
|
||||
((fresh (a d rest-sum) (conso a d l) (sumo d rest-sum) (pluso-i a rest-sum total))))))
|
||||
|
||||
(define
|
||||
producto
|
||||
(fn
|
||||
(l total)
|
||||
(conde
|
||||
((nullo l) (== total 1))
|
||||
((fresh (a d rest-prod) (conso a d l) (producto d rest-prod) (*o-i a rest-prod total))))))
|
||||
|
||||
(define
|
||||
lengtho-i
|
||||
(fn
|
||||
(l n)
|
||||
(conde
|
||||
((nullo l) (== n 0))
|
||||
((fresh (a d n-1) (conso a d l) (lengtho-i d n-1) (pluso-i 1 n-1 n))))))
|
||||
|
||||
(define
|
||||
enumerate-from-i
|
||||
(fn
|
||||
(start l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest start-prime) (conso a d l) (conso (list start a) r-rest result) (pluso-i 1 start start-prime) (enumerate-from-i start-prime d r-rest))))))
|
||||
|
||||
(define enumerate-i (fn (l result) (enumerate-from-i 0 l result)))
|
||||
|
||||
(define
|
||||
counto
|
||||
(fn
|
||||
(x l n)
|
||||
(conde
|
||||
((nullo l) (== n 0))
|
||||
((fresh (a d n-rest) (conso a d l) (conde ((== a x) (counto x d n-rest) (pluso-i 1 n-rest n)) ((nafc (== a x)) (counto x d n))))))))
|
||||
|
||||
(define
|
||||
mk-arith-prog
|
||||
(fn
|
||||
(start step len)
|
||||
(cond
|
||||
((= len 0) (list))
|
||||
(:else (cons start (mk-arith-prog (+ start step) step (- len 1)))))))
|
||||
|
||||
(define
|
||||
arith-progo
|
||||
(fn
|
||||
(start step len result)
|
||||
(project (start step len) (== result (mk-arith-prog start step len)))))
|
||||
@@ -1,76 +0,0 @@
|
||||
;; lib/minikanren/matche.sx — Phase 5 piece D: pattern matching over terms.
|
||||
;;
|
||||
;; (matche TARGET
|
||||
;; (PATTERN1 g1 g2 ...)
|
||||
;; (PATTERN2 g1 ...)
|
||||
;; ...)
|
||||
;;
|
||||
;; Pattern grammar:
|
||||
;; _ wildcard — fresh anonymous var
|
||||
;; x plain symbol — fresh var, bind by name
|
||||
;; ATOM literal (number, string, boolean) — must equal
|
||||
;; :keyword keyword literal — emitted bare (keywords self-evaluate
|
||||
;; to their string name in SX, so quoting them changes
|
||||
;; their type from string to keyword)
|
||||
;; () empty list — must equal
|
||||
;; (p1 p2 ... pn) list pattern — recurse on each element
|
||||
;;
|
||||
;; The macro expands to a `conde` whose clauses are
|
||||
;; `((fresh (vars-in-pat) (== target pat-expr) body...))`.
|
||||
;;
|
||||
;; Repeated symbol names within a pattern produce the same fresh var, so
|
||||
;; they unify by `==`. Fixed-length list patterns only — head/tail
|
||||
;; destructuring uses `(fresh (a d) (conso a d target) body)` directly.
|
||||
;;
|
||||
;; Note: the macro builds the expansion via `cons` / `list` rather than a
|
||||
;; quasiquote — quasiquote does not recurse into nested lambda bodies in
|
||||
;; SX, so `\`(matche-clause (quote ,target) cl)` left literal
|
||||
;; `(unquote target)` in the output.
|
||||
|
||||
(define matche-symbol-var? (fn (s) (symbol? s)))
|
||||
|
||||
(define
|
||||
matche-collect-vars-acc
|
||||
(fn
|
||||
(pat acc)
|
||||
(cond
|
||||
((matche-symbol-var? pat)
|
||||
(if (some (fn (s) (= s pat)) acc) acc (append acc (list pat))))
|
||||
((and (list? pat) (not (empty? pat)))
|
||||
(reduce (fn (a p) (matche-collect-vars-acc p a)) acc pat))
|
||||
(:else acc))))
|
||||
|
||||
(define
|
||||
matche-collect-vars
|
||||
(fn (pat) (matche-collect-vars-acc pat (list))))
|
||||
|
||||
(define
|
||||
matche-pattern->expr
|
||||
(fn
|
||||
(pat)
|
||||
(cond
|
||||
((matche-symbol-var? pat) pat)
|
||||
((and (list? pat) (empty? pat)) (list (quote list)))
|
||||
((list? pat) (cons (quote list) (map matche-pattern->expr pat)))
|
||||
((keyword? pat) pat)
|
||||
(:else (list (quote quote) pat)))))
|
||||
|
||||
(define
|
||||
matche-clause
|
||||
(fn
|
||||
(target cl)
|
||||
(let
|
||||
((pat (first cl)) (body (rest cl)))
|
||||
(let
|
||||
((vars (matche-collect-vars pat)))
|
||||
(let
|
||||
((pat-expr (matche-pattern->expr pat)))
|
||||
(list
|
||||
(cons
|
||||
(quote fresh)
|
||||
(cons vars (cons (list (quote ==) target pat-expr) body)))))))))
|
||||
|
||||
(defmacro
|
||||
matche
|
||||
(target &rest clauses)
|
||||
(cons (quote conde) (map (fn (cl) (matche-clause target cl)) clauses)))
|
||||
@@ -1,24 +0,0 @@
|
||||
;; lib/minikanren/nafc.sx — Phase 5 piece C: negation as finite failure.
|
||||
;;
|
||||
;; (nafc g)
|
||||
;; succeeds (yields the input substitution) if g has zero answers
|
||||
;; against that substitution; fails (mzero) if g has at least one.
|
||||
;;
|
||||
;; Caveat: `nafc` is unsound under the open-world assumption. It only
|
||||
;; makes sense for goals over fully-ground terms, or with the explicit
|
||||
;; understanding that adding more facts could flip the answer. Use
|
||||
;; `(project (...) ...)` to ensure the relevant vars are ground first.
|
||||
;;
|
||||
;; Caveat 2: stream-take forces g for at least one answer; if g is
|
||||
;; infinitely-ground (say, a divergent search over an unbound list),
|
||||
;; nafc itself will diverge. Standard miniKanren limitation.
|
||||
|
||||
(define
|
||||
nafc
|
||||
(fn
|
||||
(g)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((peek (stream-take 1 (g s))))
|
||||
(if (empty? peek) (unit s) mzero)))))
|
||||
@@ -1,51 +0,0 @@
|
||||
;; lib/minikanren/peano.sx — Peano-encoded natural-number relations.
|
||||
;;
|
||||
;; Same encoding as `lengtho`: zero is the keyword `:z`; successors are
|
||||
;; `(:s n)`. So 3 = `(:s (:s (:s :z)))`. `(:z)` and `(:s ...)` are normal
|
||||
;; SX values that unify positionally — no special primitives needed.
|
||||
;;
|
||||
;; Peano arithmetic is the canonical miniKanren way to test addition /
|
||||
;; multiplication / less-than relationally without an FD constraint store.
|
||||
;; (CLP(FD) integers come in Phase 6.)
|
||||
|
||||
(define zeroo (fn (n) (== n :z)))
|
||||
|
||||
(define succ-of (fn (n m) (== m (list :s n))))
|
||||
|
||||
(define
|
||||
pluso
|
||||
(fn
|
||||
(a b c)
|
||||
(conde
|
||||
((== a :z) (== b c))
|
||||
((fresh (a-1 c-1) (== a (list :s a-1)) (== c (list :s c-1)) (pluso a-1 b c-1))))))
|
||||
|
||||
(define minuso (fn (a b c) (pluso b c a)))
|
||||
|
||||
(define lteo (fn (a b) (fresh (k) (pluso a k b))))
|
||||
|
||||
(define lto (fn (a b) (fresh (sa) (succ-of a sa) (lteo sa b))))
|
||||
|
||||
(define
|
||||
eveno
|
||||
(fn
|
||||
(n)
|
||||
(conde
|
||||
((== n :z))
|
||||
((fresh (m) (== n (list :s (list :s m))) (eveno m))))))
|
||||
|
||||
(define
|
||||
oddo
|
||||
(fn
|
||||
(n)
|
||||
(conde
|
||||
((== n (list :s :z)))
|
||||
((fresh (m) (== n (list :s (list :s m))) (oddo m))))))
|
||||
|
||||
(define
|
||||
*o
|
||||
(fn
|
||||
(a b c)
|
||||
(conde
|
||||
((== a :z) (== c :z))
|
||||
((fresh (a-1 ab-1) (== a (list :s a-1)) (*o a-1 b ab-1) (pluso b ab-1 c))))))
|
||||
@@ -1,25 +0,0 @@
|
||||
;; lib/minikanren/project.sx — Phase 5 piece B: `project`.
|
||||
;;
|
||||
;; (project (x y) g1 g2 ...)
|
||||
;; — rebinds each named var to (mk-walk* var s) within the body's
|
||||
;; lexical scope, then runs the conjunction of the body goals on
|
||||
;; the same substitution. Use to escape into regular SX (arithmetic,
|
||||
;; string ops, host predicates) when you need a ground value.
|
||||
;;
|
||||
;; If any of the projected vars is still unbound at this point, the body
|
||||
;; sees the raw `(:var NAME)` term — that is intentional and lets you
|
||||
;; mix project with `(== ground? var)` patterns or with conda guards.
|
||||
;;
|
||||
;; Hygiene: substitution parameter is gensym'd so it doesn't capture user
|
||||
;; vars (`s` is a popular relation parameter name).
|
||||
|
||||
(defmacro
|
||||
project
|
||||
(vars &rest goals)
|
||||
(let
|
||||
((s-sym (gensym "proj-s-")))
|
||||
(quasiquote
|
||||
(fn
|
||||
((unquote s-sym))
|
||||
((let (unquote (map (fn (v) (list v (list (quote mk-walk*) v s-sym))) vars)) (mk-conj (splice-unquote goals)))
|
||||
(unquote s-sym))))))
|
||||
@@ -1,67 +0,0 @@
|
||||
;; lib/minikanren/queens.sx — N-queens via ino + all-distincto + project.
|
||||
;;
|
||||
;; Encoding: q = (c1 c2 ... cn) where ci is the column of the queen in
|
||||
;; row i. Each ci ∈ {1..n}; all distinct (no two queens share a column);
|
||||
;; no two queens on the same diagonal (|ci - cj| ≠ |i - j| for i ≠ j).
|
||||
;;
|
||||
;; The diagonal check uses `project` to escape into host arithmetic
|
||||
;; once both column values are ground.
|
||||
|
||||
(define
|
||||
safe-diag
|
||||
(fn
|
||||
(a b dist)
|
||||
(project (a b) (if (= (abs (- a b)) dist) fail succeed))))
|
||||
|
||||
(define
|
||||
safe-cell-vs-rest
|
||||
(fn
|
||||
(c c-row others next-row)
|
||||
(cond
|
||||
((empty? others) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(safe-diag c (first others) (- next-row c-row))
|
||||
(safe-cell-vs-rest c c-row (rest others) (+ next-row 1)))))))
|
||||
|
||||
(define
|
||||
all-cells-safe
|
||||
(fn
|
||||
(cols start-row)
|
||||
(cond
|
||||
((empty? cols) succeed)
|
||||
(:else
|
||||
(mk-conj
|
||||
(safe-cell-vs-rest
|
||||
(first cols)
|
||||
start-row
|
||||
(rest cols)
|
||||
(+ start-row 1))
|
||||
(all-cells-safe (rest cols) (+ start-row 1)))))))
|
||||
|
||||
(define
|
||||
range-1-to-n
|
||||
(fn
|
||||
(n)
|
||||
(cond
|
||||
((= n 0) (list))
|
||||
(:else (append (range-1-to-n (- n 1)) (list n))))))
|
||||
|
||||
(define
|
||||
ino-each
|
||||
(fn
|
||||
(cols dom)
|
||||
(cond
|
||||
((empty? cols) succeed)
|
||||
(:else (mk-conj (ino (first cols) dom) (ino-each (rest cols) dom))))))
|
||||
|
||||
(define
|
||||
queens-cols
|
||||
(fn
|
||||
(cols n)
|
||||
(let
|
||||
((dom (range-1-to-n n)))
|
||||
(mk-conj
|
||||
(ino-each cols dom)
|
||||
(all-distincto cols)
|
||||
(all-cells-safe cols 1)))))
|
||||
@@ -1,361 +0,0 @@
|
||||
;; lib/minikanren/relations.sx — Phase 4 standard relations.
|
||||
;;
|
||||
;; Programs use native SX lists as data. Relations decompose lists via the
|
||||
;; tagged cons-cell shape `(:cons h t)` because SX has no improper pairs;
|
||||
;; the unifier treats `(:cons h t)` and the native list `(h . t)` as
|
||||
;; equivalent, and `mk-walk*` flattens cons cells back to flat lists for
|
||||
;; reification.
|
||||
|
||||
;; --- pair / list shape relations ---
|
||||
|
||||
(define nullo (fn (l) (== l (list))))
|
||||
|
||||
(define pairo (fn (p) (fresh (a d) (== p (mk-cons a d)))))
|
||||
|
||||
(define caro (fn (p a) (fresh (d) (== p (mk-cons a d)))))
|
||||
|
||||
(define cdro (fn (p d) (fresh (a) (== p (mk-cons a d)))))
|
||||
|
||||
(define conso (fn (a d p) (== p (mk-cons a d))))
|
||||
|
||||
(define firsto caro)
|
||||
(define resto cdro)
|
||||
|
||||
(define
|
||||
listo
|
||||
(fn (l) (conde ((nullo l)) ((fresh (a d) (conso a d l) (listo d))))))
|
||||
|
||||
;; --- appendo: the canary ---
|
||||
;;
|
||||
;; (appendo l s ls) — `ls` is the concatenation of `l` and `s`.
|
||||
;; Runs forwards (l, s known → ls), backwards (ls known → all (l, s) pairs),
|
||||
;; and bidirectionally (mix of bound + unbound).
|
||||
|
||||
(define
|
||||
appendo
|
||||
(fn
|
||||
(l s ls)
|
||||
(conde
|
||||
((nullo l) (== s ls))
|
||||
((fresh (a d res) (conso a d l) (conso a res ls) (appendo d s res))))))
|
||||
|
||||
;; --- membero ---
|
||||
;; (membero x l) — x appears (at least once) in l.
|
||||
|
||||
(define
|
||||
appendo3
|
||||
(fn
|
||||
(l1 l2 l3 result)
|
||||
(fresh (l12) (appendo l1 l2 l12) (appendo l12 l3 result))))
|
||||
|
||||
(define
|
||||
partitiono
|
||||
(fn
|
||||
(pred l yes no)
|
||||
(conde
|
||||
((nullo l) (nullo yes) (nullo no))
|
||||
((fresh (a d y-rest n-rest) (conso a d l) (conde ((pred a) (conso a y-rest yes) (== no n-rest) (partitiono pred d y-rest n-rest)) ((nafc (pred a)) (== yes y-rest) (conso a n-rest no) (partitiono pred d y-rest n-rest))))))))
|
||||
|
||||
(define
|
||||
foldr-o
|
||||
(fn
|
||||
(rel l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d r-rest) (conso a d l) (foldr-o rel d acc r-rest) (rel a r-rest result))))))
|
||||
|
||||
(define
|
||||
foldl-o
|
||||
(fn
|
||||
(rel l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d new-acc) (conso a d l) (rel acc a new-acc) (foldl-o rel d new-acc result))))))
|
||||
|
||||
(define
|
||||
flat-mapo
|
||||
(fn
|
||||
(rel l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d a-result rest-result) (conso a d l) (rel a a-result) (flat-mapo rel d rest-result) (appendo a-result rest-result result))))))
|
||||
|
||||
(define
|
||||
nub-o
|
||||
(fn
|
||||
(l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest) (conso a d l) (conde ((membero a d) (nub-o d result)) ((nafc (membero a d)) (conso a r-rest result) (nub-o d r-rest))))))))
|
||||
|
||||
|
||||
(define
|
||||
take-while-o
|
||||
(fn
|
||||
(pred l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d r-rest) (conso a d l) (conde ((pred a) (conso a r-rest result) (take-while-o pred d r-rest)) ((nafc (pred a)) (== result (list)))))))))
|
||||
|
||||
(define
|
||||
drop-while-o
|
||||
(fn
|
||||
(pred l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d) (conso a d l) (conde ((pred a) (drop-while-o pred d result)) ((nafc (pred a)) (== result l))))))))
|
||||
|
||||
(define
|
||||
membero
|
||||
(fn
|
||||
(x l)
|
||||
(conde
|
||||
((fresh (d) (conso x d l)))
|
||||
((fresh (a d) (conso a d l) (membero x d))))))
|
||||
|
||||
(define
|
||||
not-membero
|
||||
(fn
|
||||
(x l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (nafc (== a x)) (not-membero x d))))))
|
||||
|
||||
(define
|
||||
subseto
|
||||
(fn
|
||||
(l1 l2)
|
||||
(conde
|
||||
((nullo l1))
|
||||
((fresh (a d) (conso a d l1) (membero a l2) (subseto d l2))))))
|
||||
|
||||
(define
|
||||
reverseo
|
||||
(fn
|
||||
(l r)
|
||||
(conde
|
||||
((nullo l) (nullo r))
|
||||
((fresh (a d res-rev) (conso a d l) (reverseo d res-rev) (appendo res-rev (list a) r))))))
|
||||
|
||||
(define
|
||||
rev-acco
|
||||
(fn
|
||||
(l acc result)
|
||||
(conde
|
||||
((nullo l) (== result acc))
|
||||
((fresh (a d acc-prime) (conso a d l) (conso a acc acc-prime) (rev-acco d acc-prime result))))))
|
||||
|
||||
(define rev-2o (fn (l result) (rev-acco l (list) result)))
|
||||
|
||||
(define palindromeo (fn (l) (fresh (rev) (reverseo l rev) (== l rev))))
|
||||
|
||||
(define prefixo (fn (p l) (fresh (rest) (appendo p rest l))))
|
||||
|
||||
(define suffixo (fn (s l) (fresh (front) (appendo front s l))))
|
||||
|
||||
(define
|
||||
subo
|
||||
(fn
|
||||
(s l)
|
||||
(fresh
|
||||
(front-and-s back front)
|
||||
(appendo front-and-s back l)
|
||||
(appendo front s front-and-s))))
|
||||
|
||||
(define
|
||||
selecto
|
||||
(fn
|
||||
(x rest l)
|
||||
(conde
|
||||
((conso x rest l))
|
||||
((fresh (a d r) (conso a d l) (conso a r rest) (selecto x r d))))))
|
||||
|
||||
(define
|
||||
lengtho
|
||||
(fn
|
||||
(l n)
|
||||
(conde
|
||||
((nullo l) (== n :z))
|
||||
((fresh (a d n-1) (conso a d l) (== n (list :s n-1)) (lengtho d n-1))))))
|
||||
|
||||
(define
|
||||
inserto
|
||||
(fn
|
||||
(a l p)
|
||||
(conde
|
||||
((conso a l p))
|
||||
((fresh (h t pt) (conso h t l) (conso h pt p) (inserto a t pt))))))
|
||||
|
||||
(define
|
||||
permuteo
|
||||
(fn
|
||||
(l p)
|
||||
(conde
|
||||
((nullo l) (nullo p))
|
||||
((fresh (a d perm-d) (conso a d l) (permuteo d perm-d) (inserto a perm-d p))))))
|
||||
|
||||
(define
|
||||
flatteno
|
||||
(fn
|
||||
(tree flat)
|
||||
(conde
|
||||
((nullo tree) (nullo flat))
|
||||
((pairo tree)
|
||||
(fresh
|
||||
(h t hf tf)
|
||||
(conso h t tree)
|
||||
(flatteno h hf)
|
||||
(flatteno t tf)
|
||||
(appendo hf tf flat)))
|
||||
((nafc (nullo tree)) (nafc (pairo tree)) (== flat (list tree))))))
|
||||
|
||||
(define
|
||||
rembero
|
||||
(fn
|
||||
(x l out)
|
||||
(conde
|
||||
((nullo l) (nullo out))
|
||||
((fresh (a d) (conso a d l) (== a x) (== out d)))
|
||||
((fresh (a d res) (conso a d l) (nafc (== a x)) (conso a res out) (rembero x d res))))))
|
||||
|
||||
(define
|
||||
removeo-allo
|
||||
(fn
|
||||
(x l result)
|
||||
(conde
|
||||
((nullo l) (nullo result))
|
||||
((fresh (a d) (conso a d l) (== a x) (removeo-allo x d result)))
|
||||
((fresh (a d r-rest) (conso a d l) (nafc (== a x)) (conso a r-rest result) (removeo-allo x d r-rest))))))
|
||||
|
||||
(define
|
||||
assoco
|
||||
(fn
|
||||
(key pairs val)
|
||||
(fresh
|
||||
(rest)
|
||||
(conde
|
||||
((conso (list key val) rest pairs))
|
||||
((fresh (other) (conso other rest pairs) (assoco key rest val)))))))
|
||||
|
||||
(define
|
||||
nth-o
|
||||
(fn
|
||||
(n l elem)
|
||||
(conde
|
||||
((== n :z) (fresh (d) (conso elem d l)))
|
||||
((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (nth-o n-1 d elem))))))
|
||||
|
||||
(define
|
||||
samelengtho
|
||||
(fn
|
||||
(l1 l2)
|
||||
(conde
|
||||
((nullo l1) (nullo l2))
|
||||
((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (samelengtho d d-prime))))))
|
||||
|
||||
(define
|
||||
mapo
|
||||
(fn
|
||||
(rel l1 l2)
|
||||
(conde
|
||||
((nullo l1) (nullo l2))
|
||||
((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (rel a a-prime) (mapo rel d d-prime))))))
|
||||
|
||||
(define
|
||||
iterate-no
|
||||
(fn
|
||||
(rel n x result)
|
||||
(conde
|
||||
((== n :z) (== result x))
|
||||
((fresh (n-1 mid) (== n (list :s n-1)) (rel x mid) (iterate-no rel n-1 mid result))))))
|
||||
|
||||
(define
|
||||
pairlisto
|
||||
(fn
|
||||
(l1 l2 pairs)
|
||||
(conde
|
||||
((nullo l1) (nullo l2) (nullo pairs))
|
||||
((fresh (a1 d1 a2 d2 d-pairs) (conso a1 d1 l1) (conso a2 d2 l2) (conso (list a1 a2) d-pairs pairs) (pairlisto d1 d2 d-pairs))))))
|
||||
|
||||
(define
|
||||
zip-with-o
|
||||
(fn
|
||||
(rel l1 l2 result)
|
||||
(conde
|
||||
((nullo l1) (nullo l2) (nullo result))
|
||||
((fresh (a1 d1 a2 d2 a-result d-result) (conso a1 d1 l1) (conso a2 d2 l2) (rel a1 a2 a-result) (conso a-result d-result result) (zip-with-o rel d1 d2 d-result))))))
|
||||
|
||||
(define
|
||||
swap-firsto
|
||||
(fn
|
||||
(l result)
|
||||
(fresh
|
||||
(a b rest mid-l mid-r)
|
||||
(conso a mid-l l)
|
||||
(conso b rest mid-l)
|
||||
(conso b mid-r result)
|
||||
(conso a rest mid-r))))
|
||||
|
||||
(define
|
||||
everyo
|
||||
(fn
|
||||
(rel l)
|
||||
(conde
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (rel a) (everyo rel d))))))
|
||||
|
||||
(define
|
||||
someo
|
||||
(fn
|
||||
(rel l)
|
||||
(conde
|
||||
((fresh (a d) (conso a d l) (rel a)))
|
||||
((fresh (a d) (conso a d l) (someo rel d))))))
|
||||
|
||||
(define
|
||||
lasto
|
||||
(fn
|
||||
(l x)
|
||||
(conde
|
||||
((conso x (list) l))
|
||||
((fresh (a d) (conso a d l) (lasto d x))))))
|
||||
|
||||
(define
|
||||
init-o
|
||||
(fn
|
||||
(l init)
|
||||
(conde
|
||||
((fresh (x) (conso x (list) l) (== init (list))))
|
||||
((fresh (a d d-init) (conso a d l) (conso a d-init init) (init-o d d-init))))))
|
||||
|
||||
(define
|
||||
tako
|
||||
(fn
|
||||
(n l prefix)
|
||||
(conde
|
||||
((== n :z) (== prefix (list)))
|
||||
((fresh (n-1 a d p-rest) (== n (list :s n-1)) (conso a d l) (conso a p-rest prefix) (tako n-1 d p-rest))))))
|
||||
|
||||
(define
|
||||
dropo
|
||||
(fn
|
||||
(n l suffix)
|
||||
(conde
|
||||
((== n :z) (== suffix l))
|
||||
((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (dropo n-1 d suffix))))))
|
||||
|
||||
(define
|
||||
repeato
|
||||
(fn
|
||||
(x n result)
|
||||
(conde
|
||||
((== n :z) (== result (list)))
|
||||
((fresh (n-1 r-rest) (== n (list :s n-1)) (conso x r-rest result) (repeato x n-1 r-rest))))))
|
||||
|
||||
(define
|
||||
concato
|
||||
(fn
|
||||
(lists result)
|
||||
(conde
|
||||
((nullo lists) (nullo result))
|
||||
((fresh (h t r-rest) (conso h t lists) (appendo h r-rest result) (concato t r-rest))))))
|
||||
@@ -1,56 +0,0 @@
|
||||
;; lib/minikanren/run.sx — Phase 3: drive a goal + reify the query var.
|
||||
;;
|
||||
;; reify-name N — make the canonical "_.N" reified symbol.
|
||||
;; reify-s term rs — walk term in rs, add a mapping from each fresh
|
||||
;; unbound var to its _.N name (left-to-right order).
|
||||
;; reify q s — walk* q in s, build reify-s, walk* again to
|
||||
;; substitute reified names in.
|
||||
;; run-n n q-name g... — defmacro: bind q-name to a fresh var, conj goals,
|
||||
;; take ≤ n answers from the stream, reify each
|
||||
;; through q-name. n = -1 takes all (used by run*).
|
||||
;; run* — defmacro: (run* q g...) ≡ (run-n -1 q g...)
|
||||
;; run — defmacro: (run n q g...) ≡ (run-n n q g...)
|
||||
;; The two-segment form is the standard TRS API.
|
||||
|
||||
(define reify-name (fn (n) (make-symbol (str "_." n))))
|
||||
|
||||
(define
|
||||
reify-s
|
||||
(fn
|
||||
(term rs)
|
||||
(let
|
||||
((w (mk-walk term rs)))
|
||||
(cond
|
||||
((is-var? w) (extend (var-name w) (reify-name (len rs)) rs))
|
||||
((mk-list-pair? w) (reduce (fn (acc a) (reify-s a acc)) rs w))
|
||||
(:else rs)))))
|
||||
|
||||
(define
|
||||
reify
|
||||
(fn
|
||||
(term s)
|
||||
(let
|
||||
((w (mk-walk* term s)))
|
||||
(let ((rs (reify-s w (empty-subst)))) (mk-walk* w rs)))))
|
||||
|
||||
(defmacro
|
||||
run-n
|
||||
(n q-name &rest goals)
|
||||
(quasiquote
|
||||
(let
|
||||
(((unquote q-name) (make-var)))
|
||||
(map
|
||||
(fn (s) (reify (unquote q-name) s))
|
||||
(stream-take
|
||||
(unquote n)
|
||||
((mk-conj (splice-unquote goals)) empty-s))))))
|
||||
|
||||
(defmacro
|
||||
run*
|
||||
(q-name &rest goals)
|
||||
(quasiquote (run-n -1 (unquote q-name) (splice-unquote goals))))
|
||||
|
||||
(defmacro
|
||||
run
|
||||
(n q-name &rest goals)
|
||||
(quasiquote (run-n (unquote n) (unquote q-name) (splice-unquote goals))))
|
||||
@@ -1,66 +0,0 @@
|
||||
;; lib/minikanren/stream.sx — Phase 2 piece A: lazy streams of substitutions.
|
||||
;;
|
||||
;; SX has no improper pairs (cons requires a list cdr), so we use a
|
||||
;; tagged stream-cell shape for mature stream elements:
|
||||
;;
|
||||
;; stream ::= mzero empty (the SX empty list)
|
||||
;; | (:s HEAD TAIL) mature cell, TAIL is a stream
|
||||
;; | thunk (fn () ...) → stream when forced
|
||||
;;
|
||||
;; HEAD is a substitution dict. TAIL is again a stream (possibly a thunk),
|
||||
;; which is what gives us laziness — mk-mplus can return a mature head with
|
||||
;; a thunk in the tail, deferring the rest of the search.
|
||||
|
||||
(define mzero (list))
|
||||
|
||||
(define s-cons (fn (h t) (list :s h t)))
|
||||
|
||||
(define
|
||||
s-cons?
|
||||
(fn (s) (and (list? s) (not (empty? s)) (= (first s) :s))))
|
||||
|
||||
(define s-car (fn (s) (nth s 1)))
|
||||
(define s-cdr (fn (s) (nth s 2)))
|
||||
|
||||
(define unit (fn (s) (s-cons s mzero)))
|
||||
|
||||
(define stream-pause? (fn (s) (and (not (list? s)) (callable? s))))
|
||||
|
||||
;; mk-mplus — interleave two streams. If s1 is paused we suspend and
|
||||
;; swap (Reasoned Schemer "interleave"); otherwise mature-cons head with
|
||||
;; mk-mplus of the rest.
|
||||
(define
|
||||
mk-mplus
|
||||
(fn
|
||||
(s1 s2)
|
||||
(cond
|
||||
((empty? s1) s2)
|
||||
((stream-pause? s1) (fn () (mk-mplus s2 (s1))))
|
||||
(:else (s-cons (s-car s1) (mk-mplus (s-cdr s1) s2))))))
|
||||
|
||||
;; mk-bind — apply goal g to every substitution in stream s, mk-mplus-ing.
|
||||
(define
|
||||
mk-bind
|
||||
(fn
|
||||
(s g)
|
||||
(cond
|
||||
((empty? s) mzero)
|
||||
((stream-pause? s) (fn () (mk-bind (s) g)))
|
||||
(:else (mk-mplus (g (s-car s)) (mk-bind (s-cdr s) g))))))
|
||||
|
||||
;; stream-take — force up to n results out of a (possibly lazy) stream
|
||||
;; into a flat SX list of substitutions. n = -1 means take all.
|
||||
(define
|
||||
stream-take
|
||||
(fn
|
||||
(n s)
|
||||
(cond
|
||||
((= n 0) (list))
|
||||
((empty? s) (list))
|
||||
((stream-pause? s) (stream-take n (s)))
|
||||
(:else
|
||||
(cons
|
||||
(s-car s)
|
||||
(stream-take
|
||||
(if (= n -1) -1 (- n 1))
|
||||
(s-cdr s)))))))
|
||||
@@ -1,157 +0,0 @@
|
||||
;; lib/minikanren/tabling.sx — Phase 7 piece A: naive memoization.
|
||||
;;
|
||||
;; A `table-2` wrapper for 2-arg relations (input, output). Caches by
|
||||
;; ground input (walked at call time). On hit, replays the cached output
|
||||
;; values; on miss, runs the relation, collects all output values from
|
||||
;; the answer stream, stores, then replays.
|
||||
;;
|
||||
;; Limitations of naive memoization (vs proper SLG / producer-consumer
|
||||
;; tabling):
|
||||
;; - Each call must terminate before its result enters the cache —
|
||||
;; so cyclic recursive calls with the SAME ground input would still
|
||||
;; diverge (not addressed here).
|
||||
;; - Caching by full ground walk only; partially-ground args fall
|
||||
;; through to the underlying relation.
|
||||
;;
|
||||
;; Despite the limitations, naive memoization is enough for the
|
||||
;; canonical demo: Fibonacci goes from exponential to linear because
|
||||
;; each fib(k) result is computed at most once.
|
||||
;;
|
||||
;; Cache lifetime: a single global mk-tab-cache. Use `(mk-tab-clear!)`
|
||||
;; between independent queries.
|
||||
|
||||
(define mk-tab-cache {})
|
||||
|
||||
(define mk-tab-clear! (fn () (set! mk-tab-cache {})))
|
||||
|
||||
(define
|
||||
mk-tab-lookup
|
||||
(fn
|
||||
(key)
|
||||
(cond
|
||||
((has-key? mk-tab-cache key) (get mk-tab-cache key))
|
||||
(:else :miss))))
|
||||
|
||||
(define
|
||||
mk-tab-store!
|
||||
(fn (key vals) (set! mk-tab-cache (assoc mk-tab-cache key vals))))
|
||||
|
||||
(define
|
||||
mk-tab-ground-term?
|
||||
(fn
|
||||
(t)
|
||||
(cond
|
||||
((is-var? t) false)
|
||||
((mk-cons-cell? t)
|
||||
(and
|
||||
(mk-tab-ground-term? (mk-cons-head t))
|
||||
(mk-tab-ground-term? (mk-cons-tail t))))
|
||||
((mk-list-pair? t) (every? mk-tab-ground-term? t))
|
||||
(:else true))))
|
||||
|
||||
(define
|
||||
mk-tab-replay-vals
|
||||
(fn
|
||||
(vals output s)
|
||||
(cond
|
||||
((empty? vals) mzero)
|
||||
(:else
|
||||
(let
|
||||
((sp (mk-unify output (first vals) s)))
|
||||
(let
|
||||
((this-stream (cond ((= sp nil) mzero) (:else (unit sp)))))
|
||||
(mk-mplus this-stream (mk-tab-replay-vals (rest vals) output s))))))))
|
||||
|
||||
(define
|
||||
table-2
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(input output)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((winput (mk-walk* input s)))
|
||||
(cond
|
||||
((mk-tab-ground-term? winput)
|
||||
(let
|
||||
((key (str name "@" winput)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((all-substs (stream-take -1 ((rel-fn input output) s))))
|
||||
(let
|
||||
((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
|
||||
(begin
|
||||
(mk-tab-store! key vals)
|
||||
(mk-tab-replay-vals vals output s)))))
|
||||
(:else (mk-tab-replay-vals cached output s))))))
|
||||
(:else ((rel-fn input output) s))))))))
|
||||
|
||||
;; --- table-1: 1-arg relation (one input, no output to cache) ---
|
||||
;; The relation is a predicate `(p input)` that succeeds or fails.
|
||||
;; Cache stores either :ok or :no.
|
||||
|
||||
(define
|
||||
table-1
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(input)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((winput (mk-walk* input s)))
|
||||
(cond
|
||||
((mk-tab-ground-term? winput)
|
||||
(let
|
||||
((key (str name "@1@" winput)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((stream ((rel-fn input) s)))
|
||||
(let
|
||||
((peek (stream-take 1 stream)))
|
||||
(cond
|
||||
((empty? peek)
|
||||
(begin (mk-tab-store! key :no) mzero))
|
||||
(:else (begin (mk-tab-store! key :ok) stream))))))
|
||||
((= cached :ok) (unit s))
|
||||
((= cached :no) mzero)
|
||||
(:else mzero)))))
|
||||
(:else ((rel-fn input) s))))))))
|
||||
|
||||
;; --- table-3: 3-arg relation (input1 input2 output) ---
|
||||
;; Cache keyed by (input1, input2). Output values cached as a list.
|
||||
|
||||
(define
|
||||
table-3
|
||||
(fn
|
||||
(name rel-fn)
|
||||
(fn
|
||||
(i1 i2 output)
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((wi1 (mk-walk* i1 s)) (wi2 (mk-walk* i2 s)))
|
||||
(cond
|
||||
((and (mk-tab-ground-term? wi1) (mk-tab-ground-term? wi2))
|
||||
(let
|
||||
((key (str name "@3@" wi1 "/" wi2)))
|
||||
(let
|
||||
((cached (mk-tab-lookup key)))
|
||||
(cond
|
||||
((= cached :miss)
|
||||
(let
|
||||
((all-substs (stream-take -1 ((rel-fn i1 i2 output) s))))
|
||||
(let
|
||||
((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
|
||||
(begin
|
||||
(mk-tab-store! key vals)
|
||||
(mk-tab-replay-vals vals output s)))))
|
||||
(:else (mk-tab-replay-vals cached output s))))))
|
||||
(:else ((rel-fn i1 i2 output) s))))))))
|
||||
@@ -1,49 +0,0 @@
|
||||
;; lib/minikanren/tests/appendo3.sx — 3-list append.
|
||||
|
||||
(mk-test
|
||||
"appendo3-forward"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
(list 3 4)
|
||||
(list 5 6)
|
||||
q))
|
||||
(list
|
||||
(list 1 2 3 4 5 6)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-everything"
|
||||
(run* q (appendo3 (list) (list) (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-recover-middle"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
q
|
||||
(list 5 6)
|
||||
(list 1 2 3 4 5 6)))
|
||||
(list (list 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-middle"
|
||||
(run*
|
||||
q
|
||||
(appendo3
|
||||
(list 1 2)
|
||||
(list)
|
||||
(list 3 4)
|
||||
q))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo3-empty-first-and-last"
|
||||
(run*
|
||||
q
|
||||
(appendo3 (list) (list 1 2 3) (list) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,33 +0,0 @@
|
||||
;; lib/minikanren/tests/arith-prog.sx — arithmetic progression generation.
|
||||
|
||||
(mk-test
|
||||
"arith-progo-zero-len"
|
||||
(run* q (arith-progo 5 1 0 q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-1-to-5"
|
||||
(run* q (arith-progo 1 1 5 q))
|
||||
(list (list 1 2 3 4 5)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-evens-from-0"
|
||||
(run* q (arith-progo 0 2 5 q))
|
||||
(list (list 0 2 4 6 8)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-descending"
|
||||
(run* q (arith-progo 10 -1 4 q))
|
||||
(list (list 10 9 8 7)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-zero-step"
|
||||
(run* q (arith-progo 7 0 3 q))
|
||||
(list (list 7 7 7)))
|
||||
|
||||
(mk-test
|
||||
"arith-progo-negative-start"
|
||||
(run* q (arith-progo -3 2 4 q))
|
||||
(list (list -3 -1 1 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,54 +0,0 @@
|
||||
;; lib/minikanren/tests/btree-walko.sx — walk a leaves-of-binary-tree relation
|
||||
;; using matche dispatch on (:leaf v) and (:node left right) patterns.
|
||||
|
||||
(define
|
||||
btree-walko
|
||||
(fn
|
||||
(tree v)
|
||||
(matche
|
||||
tree
|
||||
((:leaf x) (== v x))
|
||||
((:node l r) (conde ((btree-walko l v)) ((btree-walko r v)))))))
|
||||
|
||||
;; A small test tree: ((1 2) (3 (4 5))).
|
||||
(define
|
||||
test-btree
|
||||
(list
|
||||
:node (list :node (list :leaf 1) (list :leaf 2))
|
||||
(list
|
||||
:node (list :leaf 3)
|
||||
(list :node (list :leaf 4) (list :leaf 5)))))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-enumerates-all-leaves"
|
||||
(let
|
||||
((leaves (run* q (btree-walko test-btree q))))
|
||||
(and
|
||||
(= (len leaves) 5)
|
||||
(and
|
||||
(some (fn (l) (= l 1)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 2)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 3)) leaves)
|
||||
(and
|
||||
(some (fn (l) (= l 4)) leaves)
|
||||
(some (fn (l) (= l 5)) leaves)))))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"btree-walko-find-3-membership"
|
||||
(run 1 q (btree-walko test-btree 3))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-find-99-not-present"
|
||||
(run* q (btree-walko test-btree 99))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"btree-walko-leaf-only"
|
||||
(run* q (btree-walko (list :leaf 42) q))
|
||||
(list 42))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,87 +0,0 @@
|
||||
;; lib/minikanren/tests/classics.sx — small classic-style puzzles that
|
||||
;; exercise the full system end to end (relations + conde + matche +
|
||||
;; fresh + run*). Each test is a self-contained miniKanren program.
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Pet puzzle (3 friends, 3 pets, 1-each).
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(mk-test
|
||||
"classics-pet-puzzle"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b c)
|
||||
(== q (list a b c))
|
||||
(permuteo (list :dog :cat :fish) (list a b c))
|
||||
(== b :fish)
|
||||
(conde ((== a :cat)) ((== a :fish)))))
|
||||
(list (list :cat :fish :dog)))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Family-relations puzzle (uses membero on a fact list).
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define
|
||||
parent-facts
|
||||
(list
|
||||
(list "alice" "bob")
|
||||
(list "alice" "carol")
|
||||
(list "bob" "dave")
|
||||
(list "carol" "eve")
|
||||
(list "dave" "frank")))
|
||||
|
||||
(define parento (fn (x y) (membero (list x y) parent-facts)))
|
||||
|
||||
(define grandparento (fn (x z) (fresh (y) (parento x y) (parento y z))))
|
||||
|
||||
(mk-test
|
||||
"classics-grandparents-of-frank"
|
||||
(run* q (grandparento q "frank"))
|
||||
(list "bob"))
|
||||
|
||||
(mk-test
|
||||
"classics-grandchildren-of-alice"
|
||||
(run* q (grandparento "alice" q))
|
||||
(list "dave" "eve"))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Symbolic differentiation, matche-driven.
|
||||
;; Variable :x: d/dx x = 1
|
||||
;; Sum (:+ a b): d/dx (a+b) = (da + db)
|
||||
;; Product (:* a b): d/dx (a*b) = (da*b + a*db)
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define
|
||||
diffo
|
||||
(fn
|
||||
(expr var d)
|
||||
(matche
|
||||
expr
|
||||
(:x (== d 1))
|
||||
((:+ a b)
|
||||
(fresh
|
||||
(da db)
|
||||
(== d (list :+ da db))
|
||||
(diffo a var da)
|
||||
(diffo b var db)))
|
||||
((:* a b)
|
||||
(fresh
|
||||
(da db)
|
||||
(== d (list :+ (list :* da b) (list :* a db)))
|
||||
(diffo a var da)
|
||||
(diffo b var db))))))
|
||||
|
||||
(mk-test "classics-diff-of-x" (run* q (diffo :x :x q)) (list 1))
|
||||
|
||||
(mk-test
|
||||
"classics-diff-of-x-plus-x"
|
||||
(run* q (diffo (list :+ :x :x) :x q))
|
||||
(list (list :+ 1 1)))
|
||||
|
||||
(mk-test
|
||||
"classics-diff-of-x-times-x"
|
||||
(run* q (diffo (list :* :x :x) :x q))
|
||||
(list (list :+ (list :* 1 :x) (list :* :x 1))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,52 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-distinct.sx — fd-distinct (alldifferent).
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-empty"
|
||||
(run* q (fd-distinct (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-singleton"
|
||||
(run* q (fd-distinct (list 5)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-pair-distinct"
|
||||
(run* q (fd-distinct (list 1 2)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-pair-equal-fails"
|
||||
(run* q (fd-distinct (list 5 5)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-3-perms-of-3"
|
||||
(let
|
||||
((res (run* q (fresh (a b c) (fd-in a (list 1 2 3)) (fd-in b (list 1 2 3)) (fd-in c (list 1 2 3)) (fd-distinct (list a b c)) (fd-label (list a b c)) (== q (list a b c))))))
|
||||
(= (len res) 6))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-4-perms-of-4-count"
|
||||
(let
|
||||
((res (run* q (fresh (a b c d) (fd-in a (list 1 2 3 4)) (fd-in b (list 1 2 3 4)) (fd-in c (list 1 2 3 4)) (fd-in d (list 1 2 3 4)) (fd-distinct (list a b c d)) (fd-label (list a b c d)) (== q (list a b c d))))))
|
||||
(= (len res) 24))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-distinct-pigeonhole-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b c d)
|
||||
(fd-in a (list 1 2 3))
|
||||
(fd-in b (list 1 2 3))
|
||||
(fd-in c (list 1 2 3))
|
||||
(fd-in d (list 1 2 3))
|
||||
(fd-distinct (list a b c d))
|
||||
(fd-label (list a b c d))
|
||||
(== q (list a b c d))))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,133 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-domains.sx — Phase 6 piece B: domain primitives.
|
||||
|
||||
;; --- domain construction ---
|
||||
|
||||
(mk-test
|
||||
"fd-dom-from-list-sorts"
|
||||
(fd-dom-from-list
|
||||
(list 3 1 2 1 5))
|
||||
(list 1 2 3 5))
|
||||
|
||||
(mk-test "fd-dom-from-list-empty" (fd-dom-from-list (list)) (list))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-from-list-single"
|
||||
(fd-dom-from-list (list 7))
|
||||
(list 7))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-range-1-5"
|
||||
(fd-dom-range 1 5)
|
||||
(list 1 2 3 4 5))
|
||||
|
||||
(mk-test "fd-dom-range-empty" (fd-dom-range 5 1) (list))
|
||||
|
||||
;; --- predicates ---
|
||||
|
||||
(mk-test "fd-dom-empty-yes" (fd-dom-empty? (list)) true)
|
||||
(mk-test "fd-dom-empty-no" (fd-dom-empty? (list 1)) false)
|
||||
(mk-test "fd-dom-singleton-yes" (fd-dom-singleton? (list 5)) true)
|
||||
(mk-test
|
||||
"fd-dom-singleton-multi"
|
||||
(fd-dom-singleton? (list 1 2))
|
||||
false)
|
||||
(mk-test "fd-dom-singleton-empty" (fd-dom-singleton? (list)) false)
|
||||
|
||||
(mk-test
|
||||
"fd-dom-min"
|
||||
(fd-dom-min (list 3 7 9))
|
||||
3)
|
||||
(mk-test
|
||||
"fd-dom-max"
|
||||
(fd-dom-max (list 3 7 9))
|
||||
9)
|
||||
|
||||
(mk-test
|
||||
"fd-dom-member-yes"
|
||||
(fd-dom-member?
|
||||
3
|
||||
(list 1 2 3 4))
|
||||
true)
|
||||
(mk-test
|
||||
"fd-dom-member-no"
|
||||
(fd-dom-member?
|
||||
9
|
||||
(list 1 2 3 4))
|
||||
false)
|
||||
|
||||
;; --- intersect / without ---
|
||||
|
||||
(mk-test
|
||||
"fd-dom-intersect"
|
||||
(fd-dom-intersect
|
||||
(list 1 2 3 4 5)
|
||||
(list 2 4 6))
|
||||
(list 2 4))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-intersect-disjoint"
|
||||
(fd-dom-intersect
|
||||
(list 1 2 3)
|
||||
(list 4 5 6))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-intersect-empty"
|
||||
(fd-dom-intersect (list) (list 1 2 3))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-intersect-equal"
|
||||
(fd-dom-intersect
|
||||
(list 1 2 3)
|
||||
(list 1 2 3))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-without-mid"
|
||||
(fd-dom-without
|
||||
3
|
||||
(list 1 2 3 4 5))
|
||||
(list 1 2 4 5))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-without-missing"
|
||||
(fd-dom-without 9 (list 1 2 3))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"fd-dom-without-min"
|
||||
(fd-dom-without 1 (list 1 2 3))
|
||||
(list 2 3))
|
||||
|
||||
;; --- store accessors ---
|
||||
|
||||
(mk-test "fd-domain-of-unset" (fd-domain-of {} "x") nil)
|
||||
|
||||
(mk-test
|
||||
"fd-domain-of-set"
|
||||
(let
|
||||
((s (fd-set-domain {} "x" (list 1 2 3))))
|
||||
(fd-domain-of s "x"))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"fd-set-domain-empty-fails"
|
||||
(fd-set-domain {} "x" (list))
|
||||
nil)
|
||||
|
||||
(mk-test
|
||||
"fd-set-domain-overrides"
|
||||
(let
|
||||
((s (fd-set-domain {} "x" (list 1 2 3))))
|
||||
(fd-domain-of (fd-set-domain s "x" (list 5)) "x"))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"fd-set-domain-multiple-vars"
|
||||
(let
|
||||
((s (fd-set-domain (fd-set-domain {} "x" (list 1)) "y" (list 2 3))))
|
||||
(list (fd-domain-of s "x") (fd-domain-of s "y")))
|
||||
(list (list 1) (list 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,120 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-in-label.sx — fd-in (domain narrowing) + fd-label.
|
||||
|
||||
;; --- fd-in: domain narrowing ---
|
||||
|
||||
(mk-test
|
||||
"fd-in-bare-label"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 1 2 3 4 5))
|
||||
|
||||
(mk-test
|
||||
"fd-in-intersection"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-in x (list 3 4 5 6 7))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 3 4 5))
|
||||
|
||||
(mk-test
|
||||
"fd-in-disjoint-empty"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-in x (list 7 8 9))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-in-singleton-domain"
|
||||
(run*
|
||||
q
|
||||
(fresh (x) (fd-in x (list 5)) (fd-label (list x)) (== q x)))
|
||||
(list 5))
|
||||
|
||||
;; --- ground value checks the domain ---
|
||||
|
||||
(mk-test
|
||||
"fd-in-ground-in-domain"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x 3)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(== q x)))
|
||||
(list 3))
|
||||
|
||||
(mk-test
|
||||
"fd-in-ground-not-in-domain"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x 9)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(== q x)))
|
||||
(list))
|
||||
|
||||
;; --- fd-label across multiple vars ---
|
||||
|
||||
(mk-test
|
||||
"fd-label-multiple-vars"
|
||||
(let
|
||||
((res (run* q (fresh (a b) (fd-in a (list 1 2 3)) (fd-in b (list 10 20)) (fd-label (list a b)) (== q (list a b))))))
|
||||
(= (len res) 6))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-label-empty-vars"
|
||||
(run* q (fd-label (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
;; --- composition with regular goals ---
|
||||
|
||||
(mk-test
|
||||
"fd-in-with-membero-style-filtering"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in
|
||||
x
|
||||
(list
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6
|
||||
7
|
||||
8
|
||||
9
|
||||
10))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6
|
||||
7
|
||||
8
|
||||
9
|
||||
10))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,82 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-neq.sx — fd-neq with constraint propagation.
|
||||
|
||||
;; --- ground / domain interaction ---
|
||||
|
||||
(mk-test
|
||||
"fd-neq-ground-distinct"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-neq x 5)
|
||||
(fd-in x (list 4 5 6))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 4 6))
|
||||
|
||||
(mk-test
|
||||
"fd-neq-ground-equal-fails"
|
||||
(run* q (fresh (x) (== x 5) (fd-neq x 5) (== q x)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-neq-symmetric"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-neq 7 x)
|
||||
(fd-in x (list 5 6 7 8 9))
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 5 6 8 9))
|
||||
|
||||
;; --- two vars with overlapping domains ---
|
||||
|
||||
(mk-test
|
||||
"fd-neq-pair-from-3"
|
||||
(let
|
||||
((res (run* q (fresh (x y) (fd-in x (list 1 2 3)) (fd-in y (list 1 2 3)) (fd-neq x y) (fd-label (list x y)) (== q (list x y))))))
|
||||
(= (len res) 6))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-all-distinct-3-of-3"
|
||||
(let
|
||||
((res (run* q (fresh (a b c) (fd-in a (list 1 2 3)) (fd-in b (list 1 2 3)) (fd-in c (list 1 2 3)) (fd-neq a b) (fd-neq a c) (fd-neq b c) (fd-label (list a b c)) (== q (list a b c))))))
|
||||
(= (len res) 6))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-pigeonhole-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b c)
|
||||
(fd-in a (list 1 2))
|
||||
(fd-in b (list 1 2))
|
||||
(fd-in c (list 1 2))
|
||||
(fd-neq a b)
|
||||
(fd-neq a c)
|
||||
(fd-neq b c)
|
||||
(fd-label (list a b c))
|
||||
(== q (list a b c))))
|
||||
(list))
|
||||
|
||||
;; --- propagation when one side becomes ground ---
|
||||
|
||||
(mk-test
|
||||
"fd-neq-propagates-after-ground"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-in y (list 1 2 3))
|
||||
(fd-neq x y)
|
||||
(== x 2)
|
||||
(fd-label (list y))
|
||||
(== q y)))
|
||||
(list 1 3))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,128 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-ord.sx — fd-lt / fd-lte / fd-eq.
|
||||
|
||||
;; --- fd-lt ---
|
||||
|
||||
(mk-test
|
||||
"fd-lt-narrows-x-against-num"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-lt x 3)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test
|
||||
"fd-lt-narrows-x-against-num-symmetric"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-lt 3 x)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 4 5))
|
||||
|
||||
(mk-test
|
||||
"fd-lt-pair-ordered"
|
||||
(let
|
||||
((res (run* q (fresh (x y) (fd-in x (list 1 2 3 4)) (fd-in y (list 1 2 3 4)) (fd-lt x y) (fd-label (list x y)) (== q (list x y))))))
|
||||
(= (len res) 6))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"fd-lt-impossible-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 5 6 7))
|
||||
(fd-lt x 3)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list))
|
||||
|
||||
;; --- fd-lte ---
|
||||
|
||||
(mk-test
|
||||
"fd-lte-includes-equal"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-lte x 3)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"fd-lte-equal-bound"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-lte 3 x)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 3 4 5))
|
||||
|
||||
;; --- fd-eq ---
|
||||
|
||||
(mk-test
|
||||
"fd-eq-bind"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-eq x 3)
|
||||
(== q x)))
|
||||
(list 3))
|
||||
|
||||
(mk-test
|
||||
"fd-eq-out-of-domain-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-eq x 5)
|
||||
(== q x)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-eq-two-vars-share-domain"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-in y (list 2 3 4))
|
||||
(fd-eq x y)
|
||||
(fd-label (list x y))
|
||||
(== q (list x y))))
|
||||
(list (list 2 2) (list 3 3)))
|
||||
|
||||
;; --- combine fd-lt + fd-neq for "between" puzzle ---
|
||||
|
||||
(mk-test
|
||||
"fd-lt-neq-combined"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y z)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-in y (list 1 2 3))
|
||||
(fd-in z (list 1 2 3))
|
||||
(fd-lt x y)
|
||||
(fd-lt y z)
|
||||
(fd-label (list x y z))
|
||||
(== q (list x y z))))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,62 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-plus.sx — fd-plus (x + y = z).
|
||||
|
||||
(mk-test
|
||||
"fd-plus-all-ground"
|
||||
(run* q (fresh (z) (fd-plus 2 3 z) (== q z)))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-recover-x"
|
||||
(run* q (fresh (x) (fd-plus x 3 5) (== q x)))
|
||||
(list 2))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-recover-y"
|
||||
(run* q (fresh (y) (fd-plus 2 y 5) (== q y)))
|
||||
(list 3))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-impossible-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(z)
|
||||
(fd-plus 2 3 z)
|
||||
(== z 99)
|
||||
(== q z)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-domain-check"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 3 4 5))
|
||||
(fd-plus x 3 5)
|
||||
(== q x)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-pairs-summing-to-5"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y)
|
||||
(fd-in x (list 1 2 3 4))
|
||||
(fd-in y (list 1 2 3 4))
|
||||
(fd-plus x y 5)
|
||||
(fd-label (list x y))
|
||||
(== q (list x y))))
|
||||
(list
|
||||
(list 1 4)
|
||||
(list 2 3)
|
||||
(list 3 2)
|
||||
(list 4 1)))
|
||||
|
||||
(mk-test
|
||||
"fd-plus-z-derived"
|
||||
(run* q (fresh (z) (fd-plus 7 8 z) (== q z)))
|
||||
(list 15))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,85 +0,0 @@
|
||||
;; lib/minikanren/tests/clpfd-times.sx — fd-times (x * y = z).
|
||||
|
||||
(mk-test
|
||||
"fd-times-3-4"
|
||||
(run* q (fresh (z) (fd-times 3 4 z) (== q z)))
|
||||
(list 12))
|
||||
|
||||
(mk-test
|
||||
"fd-times-recover-divisor"
|
||||
(run* q (fresh (x) (fd-times x 5 30) (== q x)))
|
||||
(list 6))
|
||||
|
||||
(mk-test
|
||||
"fd-times-non-divisible-fails"
|
||||
(run* q (fresh (x) (fd-times x 5 31) (== q x)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"fd-times-by-zero"
|
||||
(run* q (fresh (z) (fd-times 0 99 z) (== q z)))
|
||||
(list 0))
|
||||
|
||||
(mk-test
|
||||
"fd-times-zero-by-anything-zero"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(fd-in x (list 1 2 3))
|
||||
(fd-times x 0 0)
|
||||
(fd-label (list x))
|
||||
(== q x)))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"fd-times-12-divisor-pairs"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y)
|
||||
(fd-in
|
||||
x
|
||||
(list
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6))
|
||||
(fd-in
|
||||
y
|
||||
(list
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6))
|
||||
(fd-times x y 12)
|
||||
(fd-label (list x y))
|
||||
(== q (list x y))))
|
||||
(list
|
||||
(list 2 6)
|
||||
(list 3 4)
|
||||
(list 4 3)
|
||||
(list 6 2)))
|
||||
|
||||
(mk-test
|
||||
"fd-times-square-of-each"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x z)
|
||||
(fd-in x (list 1 2 3 4 5))
|
||||
(fd-times x x z)
|
||||
(fd-label (list x))
|
||||
(== q (list x z))))
|
||||
(list
|
||||
(list 1 1)
|
||||
(list 2 4)
|
||||
(list 3 9)
|
||||
(list 4 16)
|
||||
(list 5 25)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,75 +0,0 @@
|
||||
;; lib/minikanren/tests/conda.sx — Phase 5 piece A tests for `conda`.
|
||||
|
||||
;; --- conda commits to first non-failing head, keeps ALL its answers ---
|
||||
|
||||
(mk-test
|
||||
"conda-first-clause-keeps-all"
|
||||
(run*
|
||||
q
|
||||
(conda
|
||||
((mk-disj (== q 1) (== q 2)))
|
||||
((== q 100))))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test
|
||||
"conda-skips-failing-head"
|
||||
(run*
|
||||
q
|
||||
(conda
|
||||
((== 1 2))
|
||||
((mk-disj (== q 10) (== q 20)))))
|
||||
(list 10 20))
|
||||
|
||||
(mk-test
|
||||
"conda-all-fail"
|
||||
(run*
|
||||
q
|
||||
(conda ((== 1 2)) ((== 3 4))))
|
||||
(list))
|
||||
|
||||
(mk-test "conda-no-clauses" (run* q (conda)) (list))
|
||||
|
||||
;; --- conda DIFFERS from condu: conda keeps all head answers ---
|
||||
|
||||
(mk-test
|
||||
"conda-vs-condu-divergence"
|
||||
(list
|
||||
(run*
|
||||
q
|
||||
(conda
|
||||
((mk-disj (== q 1) (== q 2)))
|
||||
((== q 100))))
|
||||
(run*
|
||||
q
|
||||
(condu
|
||||
((mk-disj (== q 1) (== q 2)))
|
||||
((== q 100)))))
|
||||
(list (list 1 2) (list 1)))
|
||||
|
||||
;; --- conda head's rest-goals run on every head answer ---
|
||||
|
||||
(mk-test
|
||||
"conda-rest-goals-run-on-all-answers"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x r)
|
||||
(conda
|
||||
((mk-disj (== x 1) (== x 2))
|
||||
(== r (list :tag x))))
|
||||
(== q r)))
|
||||
(list (list :tag 1) (list :tag 2)))
|
||||
|
||||
;; --- if rest-goals fail on a head answer, that head answer is filtered;
|
||||
;; the clause does not fall through to next clauses (per soft-cut). ---
|
||||
|
||||
(mk-test
|
||||
"conda-rest-fails-no-fallthrough"
|
||||
(run*
|
||||
q
|
||||
(conda
|
||||
((mk-disj (== q 1) (== q 2)) (== q 99))
|
||||
((== q 200))))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,89 +0,0 @@
|
||||
;; lib/minikanren/tests/conde.sx — Phase 2 piece C tests for `conde`.
|
||||
;;
|
||||
;; Note on ordering: conde clauses are wrapped in Zzz (inverse-eta delay),
|
||||
;; so applying the conde goal to a substitution returns thunks. mk-mplus
|
||||
;; suspends-and-swaps when its left operand is paused, giving fair
|
||||
;; interleaving — this is exactly what makes recursive relations work,
|
||||
;; but it does mean conde answers can interleave rather than appear in
|
||||
;; strict left-to-right clause order.
|
||||
|
||||
;; --- single-clause conde ≡ conj of clause body ---
|
||||
|
||||
(mk-test
|
||||
"conde-one-clause"
|
||||
(let ((q (mk-var "q"))) (run* q (conde ((== q 7)))))
|
||||
(list 7))
|
||||
|
||||
(mk-test
|
||||
"conde-one-clause-multi-goals"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(run* q (conde ((fresh (x) (== x 5) (== q (list x x)))))))
|
||||
(list (list 5 5)))
|
||||
|
||||
;; --- multi-clause: produces one row per clause (interleaved) ---
|
||||
|
||||
(mk-test
|
||||
"conde-three-clauses-as-set"
|
||||
(let
|
||||
((qs (run* q (conde ((== q 1)) ((== q 2)) ((== q 3))))))
|
||||
(and
|
||||
(= (len qs) 3)
|
||||
(and
|
||||
(some (fn (x) (= x 1)) qs)
|
||||
(and
|
||||
(some (fn (x) (= x 2)) qs)
|
||||
(some (fn (x) (= x 3)) qs)))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"conde-mixed-success-failure-as-set"
|
||||
(let
|
||||
((qs (run* q (conde ((== q "a")) ((== 1 2)) ((== q "b"))))))
|
||||
(and
|
||||
(= (len qs) 2)
|
||||
(and (some (fn (x) (= x "a")) qs) (some (fn (x) (= x "b")) qs))))
|
||||
true)
|
||||
|
||||
;; --- conde with conjuncts inside clauses ---
|
||||
|
||||
(mk-test
|
||||
"conde-clause-conj-as-set"
|
||||
(let
|
||||
((rows (run* q (fresh (x y) (conde ((== x 1) (== y 10)) ((== x 2) (== y 20))) (== q (list x y))))))
|
||||
(and
|
||||
(= (len rows) 2)
|
||||
(and
|
||||
(some (fn (r) (= r (list 1 10))) rows)
|
||||
(some (fn (r) (= r (list 2 20))) rows))))
|
||||
true)
|
||||
|
||||
;; --- nested conde ---
|
||||
|
||||
(mk-test
|
||||
"conde-nested-yields-three"
|
||||
(let
|
||||
((qs (run* q (conde ((conde ((== q 1)) ((== q 2)))) ((== q 3))))))
|
||||
(and
|
||||
(= (len qs) 3)
|
||||
(and
|
||||
(some (fn (x) (= x 1)) qs)
|
||||
(and
|
||||
(some (fn (x) (= x 2)) qs)
|
||||
(some (fn (x) (= x 3)) qs)))))
|
||||
true)
|
||||
|
||||
;; --- conde all clauses fail → empty stream ---
|
||||
|
||||
(mk-test
|
||||
"conde-all-fail"
|
||||
(run*
|
||||
q
|
||||
(conde ((== 1 2)) ((== 3 4))))
|
||||
(list))
|
||||
|
||||
;; --- empty conde: no clauses ⇒ fail ---
|
||||
|
||||
(mk-test "conde-no-clauses" (run* q (conde)) (list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,86 +0,0 @@
|
||||
;; lib/minikanren/tests/condu.sx — Phase 2 piece D tests for `onceo` and `condu`.
|
||||
|
||||
;; --- onceo: at most one answer ---
|
||||
|
||||
(mk-test
|
||||
"onceo-single-success-passes-through"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((onceo (== q 7)) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 7))
|
||||
|
||||
(mk-test
|
||||
"onceo-multi-success-trimmed-to-one"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((onceo (mk-disj (== q 1) (== q 2) (== q 3))) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"onceo-failure-stays-failure"
|
||||
((onceo (== 1 2)) empty-s)
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"onceo-conde-trimmed"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((onceo (conde ((== q "a")) ((== q "b")))) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list "a"))
|
||||
|
||||
;; --- condu: first clause with successful head wins ---
|
||||
|
||||
(mk-test
|
||||
"condu-first-clause-wins"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 10 ((condu ((== q 1)) ((== q 2))) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"condu-skips-failing-head"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 10 ((condu ((== 1 2)) ((== q 100)) ((== q 200))) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 100))
|
||||
|
||||
(mk-test
|
||||
"condu-all-fail-empty"
|
||||
((condu ((== 1 2)) ((== 3 4)))
|
||||
empty-s)
|
||||
(list))
|
||||
|
||||
(mk-test "condu-empty-clauses-fail" ((condu) empty-s) (list))
|
||||
|
||||
;; --- condu commits head's first answer; rest-goals can still backtrack
|
||||
;; within that committed substitution but cannot revisit other heads. ---
|
||||
|
||||
(mk-test
|
||||
"condu-head-onceo-rest-runs"
|
||||
(let
|
||||
((q (mk-var "q")) (r (mk-var "r")))
|
||||
(let
|
||||
((res (stream-take 10 ((condu ((mk-disj (== q 1) (== q 2)) (== r 99))) empty-s))))
|
||||
(map (fn (s) (list (mk-walk q s) (mk-walk r s))) res)))
|
||||
(list (list 1 99)))
|
||||
|
||||
(mk-test
|
||||
"condu-rest-goals-can-fail-the-clause"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 10 ((condu ((== q 1) (== 2 3)) ((== q 99))) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,35 +0,0 @@
|
||||
;; lib/minikanren/tests/counto.sx — count occurrences of x in l (intarith).
|
||||
|
||||
(mk-test
|
||||
"counto-empty"
|
||||
(run* q (counto 1 (list) q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"counto-not-found"
|
||||
(run* q (counto 99 (list 1 2 3) q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"counto-once"
|
||||
(run* q (counto 2 (list 1 2 3) q))
|
||||
(list 1))
|
||||
(mk-test
|
||||
"counto-thrice"
|
||||
(run*
|
||||
q
|
||||
(counto
|
||||
1
|
||||
(list 1 2 1 3 1)
|
||||
q))
|
||||
(list 3))
|
||||
(mk-test
|
||||
"counto-all-same"
|
||||
(run*
|
||||
q
|
||||
(counto 7 (list 7 7 7 7) q))
|
||||
(list 4))
|
||||
(mk-test
|
||||
"counto-string"
|
||||
(run* q (counto "x" (list "x" "y" "x") q))
|
||||
(list 2))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,48 +0,0 @@
|
||||
;; lib/minikanren/tests/cyclic-graph.sx — demonstrates the naive-patho
|
||||
;; behaviour on a cyclic graph. Without Phase-7 tabling/SLG, the search
|
||||
;; produces ever-longer paths revisiting the cycle. `run n` truncates;
|
||||
;; `run*` would diverge.
|
||||
|
||||
(define cyclic-edges (list (list :a :b) (list :b :a) (list :b :c)))
|
||||
|
||||
(define cyclic-edgeo (fn (x y) (membero (list x y) cyclic-edges)))
|
||||
|
||||
(define
|
||||
cyclic-patho
|
||||
(fn
|
||||
(x y path)
|
||||
(conde
|
||||
((cyclic-edgeo x y) (== path (list x y)))
|
||||
((fresh (z mid) (cyclic-edgeo x z) (cyclic-patho z y mid) (conso x mid path))))))
|
||||
|
||||
;; --- direct edge ---
|
||||
|
||||
(mk-test
|
||||
"cyclic-direct"
|
||||
(run 1 q (cyclic-patho :a :b q))
|
||||
(list (list :a :b)))
|
||||
|
||||
;; --- runs first 5 paths from a to b: bare edge, then increasing
|
||||
;; numbers of cycle traversals (a->b->a->b, etc.) ---
|
||||
|
||||
(mk-test
|
||||
"cyclic-enumerates-prefix-via-run-n"
|
||||
(let
|
||||
((paths (run 5 q (cyclic-patho :a :b q))))
|
||||
(and
|
||||
(= (len paths) 5)
|
||||
(and
|
||||
(every? (fn (p) (= (first p) :a)) paths)
|
||||
(every? (fn (p) (= (last p) :b)) paths))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"cyclic-finds-c-via-cycle-or-direct"
|
||||
(let
|
||||
((paths (run 3 q (cyclic-patho :a :c q))))
|
||||
(and
|
||||
(>= (len paths) 1)
|
||||
(some (fn (p) (= p (list :a :b :c))) paths)))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,40 +0,0 @@
|
||||
;; lib/minikanren/tests/defrel.sx — Prolog-style relation definition macro.
|
||||
|
||||
(defrel
|
||||
(my-membero x l)
|
||||
((fresh (d) (conso x d l)))
|
||||
((fresh (a d) (conso a d l) (my-membero x d))))
|
||||
|
||||
(mk-test
|
||||
"defrel-defines-membero"
|
||||
(run* q (my-membero q (list 1 2 3)))
|
||||
(list 1 2 3))
|
||||
|
||||
(defrel
|
||||
(my-listo l)
|
||||
((nullo l))
|
||||
((fresh (a d) (conso a d l) (my-listo d))))
|
||||
|
||||
(mk-test
|
||||
"defrel-listo-bounded"
|
||||
(run 3 q (my-listo q))
|
||||
(list
|
||||
(list)
|
||||
(list (make-symbol "_.0"))
|
||||
(list (make-symbol "_.0") (make-symbol "_.1"))))
|
||||
|
||||
;; Multi-arg relation with arithmetic.
|
||||
|
||||
(defrel
|
||||
(my-pluso a b c)
|
||||
((== a :z) (== b c))
|
||||
((fresh (a-1 c-1) (== a (list :s a-1)) (== c (list :s c-1)) (my-pluso a-1 b c-1))))
|
||||
|
||||
(mk-test
|
||||
"defrel-pluso-2-3"
|
||||
(run*
|
||||
q
|
||||
(my-pluso (list :s (list :s :z)) (list :s (list :s (list :s :z))) q))
|
||||
(list (list :s (list :s (list :s (list :s (list :s :z)))))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,31 +0,0 @@
|
||||
;; lib/minikanren/tests/enumerate.sx — index-each-element relation.
|
||||
|
||||
(mk-test
|
||||
"enumerate-i-empty"
|
||||
(run* q (enumerate-i (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"enumerate-i-three"
|
||||
(run* q (enumerate-i (list :a :b :c) q))
|
||||
(list
|
||||
(list (list 0 :a) (list 1 :b) (list 2 :c))))
|
||||
|
||||
(mk-test
|
||||
"enumerate-i-strings"
|
||||
(run* q (enumerate-i (list "x" "y" "z") q))
|
||||
(list
|
||||
(list (list 0 "x") (list 1 "y") (list 2 "z"))))
|
||||
|
||||
(mk-test
|
||||
"enumerate-from-i-100"
|
||||
(run* q (enumerate-from-i 100 (list :x :y :z) q))
|
||||
(list
|
||||
(list (list 100 :x) (list 101 :y) (list 102 :z))))
|
||||
|
||||
(mk-test
|
||||
"enumerate-from-i-singleton"
|
||||
(run* q (enumerate-from-i 0 (list :only) q))
|
||||
(list (list (list 0 :only))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,75 +0,0 @@
|
||||
;; lib/minikanren/tests/fd.sx — Phase 6 piece A: ino + all-distincto.
|
||||
|
||||
;; --- ino ---
|
||||
|
||||
(mk-test
|
||||
"ino-element-in-domain"
|
||||
(run* q (ino q (list 1 2 3)))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test "ino-empty-domain" (run* q (ino q (list))) (list))
|
||||
|
||||
(mk-test
|
||||
"ino-singleton-domain"
|
||||
(run* q (ino q (list 42)))
|
||||
(list 42))
|
||||
|
||||
;; --- all-distincto ---
|
||||
|
||||
(mk-test
|
||||
"all-distincto-empty"
|
||||
(run* q (all-distincto (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"all-distincto-singleton"
|
||||
(run* q (all-distincto (list 1)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"all-distincto-distinct-three"
|
||||
(run* q (all-distincto (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"all-distincto-duplicate-fails"
|
||||
(run* q (all-distincto (list 1 2 1)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"all-distincto-adjacent-duplicate-fails"
|
||||
(run* q (all-distincto (list 1 1 2)))
|
||||
(list))
|
||||
|
||||
;; --- ino + all-distincto: classic enumerate-all-permutations ---
|
||||
|
||||
(mk-test
|
||||
"fd-puzzle-three-distinct-from-domain"
|
||||
(let
|
||||
((perms (run* q (fresh (a b c) (== q (list a b c)) (ino a (list 1 2 3)) (ino b (list 1 2 3)) (ino c (list 1 2 3)) (all-distincto (list a b c))))))
|
||||
(and
|
||||
(= (len perms) 6)
|
||||
(and
|
||||
(some (fn (p) (= p (list 1 2 3))) perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 1 3 2)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 2 1 3)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 2 3 1)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 3 1 2)))
|
||||
perms)
|
||||
(some
|
||||
(fn (p) (= p (list 3 2 1)))
|
||||
perms))))))))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,39 +0,0 @@
|
||||
;; lib/minikanren/tests/flat-mapo.sx — concatMap-style relation.
|
||||
|
||||
(mk-test
|
||||
"flat-mapo-empty"
|
||||
(run* q (flat-mapo (fn (x r) (== r (list x x))) (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"flat-mapo-duplicate-each"
|
||||
(run*
|
||||
q
|
||||
(flat-mapo
|
||||
(fn (x r) (== r (list x x)))
|
||||
(list 1 2 3)
|
||||
q))
|
||||
(list
|
||||
(list 1 1 2 2 3 3)))
|
||||
|
||||
(mk-test
|
||||
"flat-mapo-empty-from-each"
|
||||
(run* q (flat-mapo (fn (x r) (== r (list))) (list :a :b :c) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"flat-mapo-singleton-from-each-is-identity"
|
||||
(run* q (flat-mapo (fn (x r) (== r (list x))) (list :a :b :c) q))
|
||||
(list (list :a :b :c)))
|
||||
|
||||
(mk-test
|
||||
"flat-mapo-tag-each"
|
||||
(run*
|
||||
q
|
||||
(flat-mapo
|
||||
(fn (x r) (== r (list :tag x)))
|
||||
(list 1 2)
|
||||
q))
|
||||
(list (list :tag 1 :tag 2)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,42 +0,0 @@
|
||||
(mk-test "flatteno-empty" (run* q (flatteno (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-atom"
|
||||
(run* q (flatteno 5 q))
|
||||
(list (list 5)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-flat-list"
|
||||
(run* q (flatteno (list 1 2 3) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-singleton"
|
||||
(run* q (flatteno (list 1) q))
|
||||
(list (list 1)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-nested-once"
|
||||
(run*
|
||||
q
|
||||
(flatteno (list 1 (list 2 3) 4) q))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-nested-twice"
|
||||
(run*
|
||||
q
|
||||
(flatteno
|
||||
(list
|
||||
1
|
||||
(list 2 (list 3 4))
|
||||
5)
|
||||
q))
|
||||
(list (list 1 2 3 4 5)))
|
||||
|
||||
(mk-test
|
||||
"flatteno-keywords"
|
||||
(run* q (flatteno (list :a (list :b :c) :d) q))
|
||||
(list (list :a :b :c :d)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,48 +0,0 @@
|
||||
;; lib/minikanren/tests/foldl-o.sx — relational left fold.
|
||||
|
||||
(mk-test
|
||||
"foldl-o-empty"
|
||||
(run* q (foldl-o pluso-i (list) 42 q))
|
||||
(list 42))
|
||||
|
||||
(mk-test
|
||||
"foldl-o-sum"
|
||||
(run*
|
||||
q
|
||||
(foldl-o
|
||||
pluso-i
|
||||
(list 1 2 3 4 5)
|
||||
0
|
||||
q))
|
||||
(list 15))
|
||||
|
||||
(mk-test
|
||||
"foldl-o-product"
|
||||
(run*
|
||||
q
|
||||
(foldl-o
|
||||
*o-i
|
||||
(list 1 2 3 4)
|
||||
1
|
||||
q))
|
||||
(list 24))
|
||||
|
||||
(mk-test
|
||||
"foldl-o-reverse-via-flip-conso"
|
||||
(run*
|
||||
q
|
||||
(foldl-o
|
||||
(fn (acc x r) (conso x acc r))
|
||||
(list 1 2 3 4)
|
||||
(list)
|
||||
q))
|
||||
(list (list 4 3 2 1)))
|
||||
|
||||
(mk-test
|
||||
"foldl-o-with-init"
|
||||
(run*
|
||||
q
|
||||
(foldl-o pluso-i (list 1 2 3) 100 q))
|
||||
(list 106))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,38 +0,0 @@
|
||||
;; lib/minikanren/tests/foldr-o.sx — relational right fold.
|
||||
|
||||
(mk-test
|
||||
"foldr-o-empty"
|
||||
(run* q (foldr-o conso (list) (list 99) q))
|
||||
(list (list 99)))
|
||||
|
||||
(mk-test
|
||||
"foldr-o-conso-rebuilds-list"
|
||||
(run* q (foldr-o conso (list 1 2 3) (list) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"foldr-o-appendo-flattens"
|
||||
(run*
|
||||
q
|
||||
(foldr-o
|
||||
appendo
|
||||
(list
|
||||
(list 1 2)
|
||||
(list 3)
|
||||
(list 4 5))
|
||||
(list)
|
||||
q))
|
||||
(list (list 1 2 3 4 5)))
|
||||
|
||||
(mk-test
|
||||
"foldr-o-with-acc-init"
|
||||
(run*
|
||||
q
|
||||
(foldr-o
|
||||
conso
|
||||
(list 1 2)
|
||||
(list 9 9)
|
||||
q))
|
||||
(list (list 1 2 9 9)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,101 +0,0 @@
|
||||
;; lib/minikanren/tests/fresh.sx — Phase 2 piece B tests for `fresh`.
|
||||
|
||||
;; --- empty fresh: pure goal grouping ---
|
||||
|
||||
(mk-test
|
||||
"fresh-empty-vars-equiv-conj"
|
||||
(stream-take 5 ((fresh () (== 1 1)) empty-s))
|
||||
(list empty-s))
|
||||
|
||||
(mk-test
|
||||
"fresh-empty-vars-no-goals-is-succeed"
|
||||
(stream-take 5 ((fresh ()) empty-s))
|
||||
(list empty-s))
|
||||
|
||||
;; --- single var ---
|
||||
|
||||
(mk-test
|
||||
"fresh-one-var-bound"
|
||||
(let
|
||||
((s (first (stream-take 5 ((fresh (x) (== x 7)) empty-s)))))
|
||||
(first (vals s)))
|
||||
7)
|
||||
|
||||
;; --- multiple vars + multiple goals ---
|
||||
|
||||
(mk-test
|
||||
"fresh-two-vars-three-goals"
|
||||
(let
|
||||
((q (mk-var "q"))
|
||||
(g
|
||||
(fresh
|
||||
(x y)
|
||||
(== x 10)
|
||||
(== y 20)
|
||||
(== q (list x y)))))
|
||||
(mk-walk* q (first (stream-take 5 (g empty-s)))))
|
||||
(list 10 20))
|
||||
|
||||
(mk-test
|
||||
"fresh-three-vars"
|
||||
(let
|
||||
((q (mk-var "q"))
|
||||
(g
|
||||
(fresh
|
||||
(a b c)
|
||||
(== a 1)
|
||||
(== b 2)
|
||||
(== c 3)
|
||||
(== q (list a b c)))))
|
||||
(mk-walk* q (first (stream-take 5 (g empty-s)))))
|
||||
(list 1 2 3))
|
||||
|
||||
;; --- fresh interacts with disj ---
|
||||
|
||||
(mk-test
|
||||
"fresh-with-disj"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((g (fresh (x) (mk-disj (== x 1) (== x 2)) (== q x))))
|
||||
(let
|
||||
((res (stream-take 5 (g empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res))))
|
||||
(list 1 2))
|
||||
|
||||
;; --- nested fresh ---
|
||||
|
||||
(mk-test
|
||||
"fresh-nested"
|
||||
(let
|
||||
((q (mk-var "q"))
|
||||
(g
|
||||
(fresh
|
||||
(x)
|
||||
(fresh
|
||||
(y)
|
||||
(== x 1)
|
||||
(== y 2)
|
||||
(== q (list x y))))))
|
||||
(mk-walk* q (first (stream-take 5 (g empty-s)))))
|
||||
(list 1 2))
|
||||
|
||||
;; --- call-fresh (functional alternative) ---
|
||||
|
||||
(mk-test
|
||||
"call-fresh-binds-and-walks"
|
||||
(let
|
||||
((s (first (stream-take 5 ((call-fresh (fn (x) (== x 99))) empty-s)))))
|
||||
(first (vals s)))
|
||||
99)
|
||||
|
||||
(mk-test
|
||||
"call-fresh-distinct-from-outer-vars"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((g (call-fresh (fn (x) (mk-conj (== x 5) (== q (list x x)))))))
|
||||
(mk-walk* q (first (stream-take 5 (g empty-s))))))
|
||||
(list 5 5))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,260 +0,0 @@
|
||||
;; lib/minikanren/tests/goals.sx — Phase 2 tests for stream.sx + goals.sx.
|
||||
;;
|
||||
;; Streams use a tagged shape internally (`(:s head tail)`) so that mature
|
||||
;; cells can have thunk tails — SX has no improper pairs. Test assertions
|
||||
;; therefore stream-take into a plain SX list, or check goal effects via
|
||||
;; mk-walk on the resulting subst, instead of inspecting raw streams.
|
||||
|
||||
;; --- stream-take base cases (input streams use s-cons / mzero) ---
|
||||
|
||||
(mk-test
|
||||
"stream-take-zero-from-mature"
|
||||
(stream-take 0 (s-cons (empty-subst) mzero))
|
||||
(list))
|
||||
|
||||
(mk-test "stream-take-from-mzero" (stream-take 5 mzero) (list))
|
||||
|
||||
(mk-test
|
||||
"stream-take-mature-pair"
|
||||
(stream-take 5 (s-cons :a (s-cons :b mzero)))
|
||||
(list :a :b))
|
||||
|
||||
(mk-test
|
||||
"stream-take-fewer-than-available"
|
||||
(stream-take 1 (s-cons :a (s-cons :b mzero)))
|
||||
(list :a))
|
||||
|
||||
(mk-test
|
||||
"stream-take-all-with-neg-1"
|
||||
(stream-take -1 (s-cons :a (s-cons :b (s-cons :c mzero))))
|
||||
(list :a :b :c))
|
||||
|
||||
;; --- stream-take forces immature thunks ---
|
||||
|
||||
(mk-test
|
||||
"stream-take-forces-thunk"
|
||||
(stream-take 5 (fn () (s-cons :x mzero)))
|
||||
(list :x))
|
||||
|
||||
(mk-test
|
||||
"stream-take-forces-nested-thunks"
|
||||
(stream-take 5 (fn () (fn () (s-cons :y mzero))))
|
||||
(list :y))
|
||||
|
||||
;; --- mk-mplus interleaves ---
|
||||
|
||||
(mk-test
|
||||
"mplus-empty-left"
|
||||
(stream-take 5 (mk-mplus mzero (s-cons :r mzero)))
|
||||
(list :r))
|
||||
|
||||
(mk-test
|
||||
"mplus-empty-right"
|
||||
(stream-take 5 (mk-mplus (s-cons :l mzero) mzero))
|
||||
(list :l))
|
||||
|
||||
(mk-test
|
||||
"mplus-mature-mature"
|
||||
(stream-take
|
||||
5
|
||||
(mk-mplus (s-cons :a (s-cons :b mzero)) (s-cons :c (s-cons :d mzero))))
|
||||
(list :a :b :c :d))
|
||||
|
||||
(mk-test
|
||||
"mplus-with-paused-left-swaps"
|
||||
(stream-take
|
||||
5
|
||||
(mk-mplus
|
||||
(fn () (s-cons :a (s-cons :b mzero)))
|
||||
(s-cons :c (s-cons :d mzero))))
|
||||
(list :c :d :a :b))
|
||||
|
||||
;; --- mk-bind ---
|
||||
|
||||
(mk-test
|
||||
"bind-empty-stream"
|
||||
(stream-take 5 (mk-bind mzero (fn (s) (unit s))))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"bind-singleton-identity"
|
||||
(stream-take
|
||||
5
|
||||
(mk-bind (s-cons 5 mzero) (fn (x) (unit x))))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"bind-flat-multi"
|
||||
(stream-take
|
||||
10
|
||||
(mk-bind
|
||||
(s-cons 1 (s-cons 2 mzero))
|
||||
(fn (x) (s-cons x (s-cons (* x 10) mzero)))))
|
||||
(list 1 10 2 20))
|
||||
|
||||
(mk-test
|
||||
"bind-fail-prunes-some"
|
||||
(stream-take
|
||||
10
|
||||
(mk-bind
|
||||
(s-cons 1 (s-cons 2 (s-cons 3 mzero)))
|
||||
(fn (x) (if (= x 2) mzero (unit x)))))
|
||||
(list 1 3))
|
||||
|
||||
;; --- core goals: succeed / fail ---
|
||||
|
||||
(mk-test
|
||||
"succeed-yields-singleton"
|
||||
(stream-take 5 (succeed empty-s))
|
||||
(list empty-s))
|
||||
|
||||
(mk-test "fail-yields-mzero" (stream-take 5 (fail empty-s)) (list))
|
||||
|
||||
;; --- == ---
|
||||
|
||||
(mk-test
|
||||
"eq-ground-success"
|
||||
(stream-take 5 ((== 1 1) empty-s))
|
||||
(list empty-s))
|
||||
|
||||
(mk-test
|
||||
"eq-ground-failure"
|
||||
(stream-take 5 ((== 1 2) empty-s))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"eq-binds-var"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(mk-walk
|
||||
x
|
||||
(first (stream-take 5 ((== x 7) empty-s)))))
|
||||
7)
|
||||
|
||||
(mk-test
|
||||
"eq-list-success"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(mk-walk
|
||||
x
|
||||
(first
|
||||
(stream-take
|
||||
5
|
||||
((== x (list 1 2)) empty-s)))))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test
|
||||
"eq-list-mismatch-fails"
|
||||
(stream-take
|
||||
5
|
||||
((== (list 1 2) (list 1 3)) empty-s))
|
||||
(list))
|
||||
|
||||
;; --- conj2 / mk-conj ---
|
||||
|
||||
(mk-test
|
||||
"conj2-both-bind"
|
||||
(let
|
||||
((x (mk-var "x")) (y (mk-var "y")))
|
||||
(let
|
||||
((s (first (stream-take 5 ((conj2 (== x 1) (== y 2)) empty-s)))))
|
||||
(list (mk-walk x s) (mk-walk y s))))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test
|
||||
"conj2-conflict-empty"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(stream-take
|
||||
5
|
||||
((conj2 (== x 1) (== x 2)) empty-s)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"conj-empty-is-succeed"
|
||||
(stream-take 5 ((mk-conj) empty-s))
|
||||
(list empty-s))
|
||||
|
||||
(mk-test
|
||||
"conj-single-is-goal"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(mk-walk
|
||||
x
|
||||
(first
|
||||
(stream-take 5 ((mk-conj (== x 99)) empty-s)))))
|
||||
99)
|
||||
|
||||
(mk-test
|
||||
"conj-three-bindings"
|
||||
(let
|
||||
((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z")))
|
||||
(let
|
||||
((s (first (stream-take 5 ((mk-conj (== x 1) (== y 2) (== z 3)) empty-s)))))
|
||||
(list (mk-walk x s) (mk-walk y s) (mk-walk z s))))
|
||||
(list 1 2 3))
|
||||
|
||||
;; --- disj2 / mk-disj ---
|
||||
|
||||
(mk-test
|
||||
"disj2-both-succeed"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((disj2 (== q 1) (== q 2)) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test
|
||||
"disj2-fail-or-succeed"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((disj2 fail (== q 5)) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"disj-empty-is-fail"
|
||||
(stream-take 5 ((mk-disj) empty-s))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"disj-three-clauses"
|
||||
(let
|
||||
((q (mk-var "q")))
|
||||
(let
|
||||
((res (stream-take 5 ((mk-disj (== q "a") (== q "b") (== q "c")) empty-s))))
|
||||
(map (fn (s) (mk-walk q s)) res)))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
;; --- conj/disj nesting ---
|
||||
|
||||
(mk-test
|
||||
"disj-of-conj"
|
||||
(let
|
||||
((x (mk-var "x")) (y (mk-var "y")))
|
||||
(let
|
||||
((res (stream-take 5 ((mk-disj (mk-conj (== x 1) (== y 2)) (mk-conj (== x 3) (== y 4))) empty-s))))
|
||||
(map (fn (s) (list (mk-walk x s) (mk-walk y s))) res)))
|
||||
(list (list 1 2) (list 3 4)))
|
||||
|
||||
;; --- ==-check ---
|
||||
|
||||
(mk-test
|
||||
"eq-check-no-occurs-fails"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(stream-take 5 ((==-check x (list 1 x)) empty-s)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"eq-check-no-occurs-non-occurring-succeeds"
|
||||
(let
|
||||
((x (mk-var "x")))
|
||||
(mk-walk
|
||||
x
|
||||
(first (stream-take 5 ((==-check x 5) empty-s)))))
|
||||
5)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,70 +0,0 @@
|
||||
;; lib/minikanren/tests/graph.sx — directed-graph reachability via patho.
|
||||
|
||||
(define
|
||||
test-edges
|
||||
(list (list :a :b) (list :b :c) (list :c :d) (list :a :c) (list :d :e)))
|
||||
|
||||
(define edgeo (fn (from to) (membero (list from to) test-edges)))
|
||||
|
||||
(define
|
||||
patho
|
||||
(fn
|
||||
(x y path)
|
||||
(conde
|
||||
((edgeo x y) (== path (list x y)))
|
||||
((fresh (z mid-path) (edgeo x z) (patho z y mid-path) (conso x mid-path path))))))
|
||||
|
||||
;; --- direct edges ---
|
||||
|
||||
(mk-test "patho-direct" (run* q (patho :a :b q)) (list (list :a :b)))
|
||||
|
||||
(mk-test "patho-no-direct-edge" (run* q (patho :e :a q)) (list))
|
||||
|
||||
;; --- indirect ---
|
||||
|
||||
(mk-test
|
||||
"patho-multi-hop"
|
||||
(let
|
||||
((paths (run* q (patho :a :d q))))
|
||||
(and
|
||||
(= (len paths) 2)
|
||||
(and
|
||||
(some (fn (p) (= p (list :a :b :c :d))) paths)
|
||||
(some (fn (p) (= p (list :a :c :d))) paths))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"patho-to-leaf"
|
||||
(let
|
||||
((paths (run* q (patho :a :e q))))
|
||||
(and
|
||||
(= (len paths) 2)
|
||||
(and
|
||||
(some (fn (p) (= p (list :a :b :c :d :e))) paths)
|
||||
(some (fn (p) (= p (list :a :c :d :e))) paths))))
|
||||
true)
|
||||
|
||||
;; --- enumeration with multiplicity ---
|
||||
;; Each path contributes one tuple, so reachable nodes can repeat. Here
|
||||
;; targets are: b (1 path), c (2 paths), d (2 paths), e (2 paths) = 7.
|
||||
|
||||
(mk-test
|
||||
"patho-enumerate-from-a-with-multiplicity"
|
||||
(let
|
||||
((targets (run* q (fresh (path) (patho :a q path)))))
|
||||
(and
|
||||
(= (len targets) 7)
|
||||
(and
|
||||
(some (fn (t) (= t :b)) targets)
|
||||
(and
|
||||
(some (fn (t) (= t :c)) targets)
|
||||
(and
|
||||
(some (fn (t) (= t :d)) targets)
|
||||
(some (fn (t) (= t :e)) targets))))))
|
||||
true)
|
||||
|
||||
;; --- unreachable target ---
|
||||
|
||||
(mk-test "patho-unreachable" (run* q (patho :a :z q)) (list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,103 +0,0 @@
|
||||
;; lib/minikanren/tests/intarith.sx — ground-only integer arithmetic
|
||||
;; goals that escape into host operations via project.
|
||||
|
||||
;; --- pluso-i ---
|
||||
|
||||
(mk-test
|
||||
"pluso-i-forward"
|
||||
(run* q (pluso-i 7 8 q))
|
||||
(list 15))
|
||||
(mk-test
|
||||
"pluso-i-zero"
|
||||
(run* q (pluso-i 0 0 q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"pluso-i-negatives"
|
||||
(run* q (pluso-i -5 3 q))
|
||||
(list -2))
|
||||
(mk-test
|
||||
"pluso-i-non-ground-fails"
|
||||
(run* q (fresh (a) (pluso-i a 3 5)))
|
||||
(list))
|
||||
|
||||
;; --- minuso-i ---
|
||||
|
||||
(mk-test
|
||||
"minuso-i-forward"
|
||||
(run* q (minuso-i 10 4 q))
|
||||
(list 6))
|
||||
(mk-test
|
||||
"minuso-i-zero"
|
||||
(run* q (minuso-i 5 5 q))
|
||||
(list 0))
|
||||
|
||||
;; --- *o-i ---
|
||||
|
||||
(mk-test
|
||||
"times-i-forward"
|
||||
(run* q (*o-i 6 7 q))
|
||||
(list 42))
|
||||
(mk-test
|
||||
"times-i-by-zero"
|
||||
(run* q (*o-i 0 99 q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"times-i-by-one"
|
||||
(run* q (*o-i 1 17 q))
|
||||
(list 17))
|
||||
|
||||
;; --- comparisons ---
|
||||
|
||||
(mk-test
|
||||
"lto-i-true"
|
||||
(run 1 q (lto-i 2 5))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "lto-i-false" (run* q (lto-i 5 2)) (list))
|
||||
(mk-test "lto-i-equal-false" (run* q (lto-i 3 3)) (list))
|
||||
|
||||
(mk-test
|
||||
"lteo-i-equal"
|
||||
(run 1 q (lteo-i 4 4))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"lteo-i-less"
|
||||
(run 1 q (lteo-i 1 4))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "lteo-i-more" (run* q (lteo-i 9 4)) (list))
|
||||
|
||||
(mk-test
|
||||
"neqo-i-different"
|
||||
(run 1 q (neqo-i 3 5))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "neqo-i-same" (run* q (neqo-i 3 3)) (list))
|
||||
|
||||
;; --- composition with relational vars ---
|
||||
|
||||
(mk-test
|
||||
"intarith-with-membero"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(membero
|
||||
x
|
||||
(list 1 2 3 4 5))
|
||||
(lto-i x 3)
|
||||
(== q x)))
|
||||
(list 1 2))
|
||||
|
||||
(mk-test "even-i-pos" (run* q (even-i 4)) (list (make-symbol "_.0")))
|
||||
|
||||
(mk-test "even-i-neg" (run* q (even-i 5)) (list))
|
||||
|
||||
(mk-test "odd-i-pos" (run* q (odd-i 7)) (list (make-symbol "_.0")))
|
||||
|
||||
(mk-test "odd-i-neg" (run* q (odd-i 4)) (list))
|
||||
|
||||
(mk-test
|
||||
"even-i-filter"
|
||||
(run* q (fresh (x) (membero x (list 1 2 3 4 5 6)) (even-i x) (== q x)))
|
||||
(list 2 4 6))
|
||||
|
||||
(mk-tests-run!)
|
||||
|
||||
@@ -1,38 +0,0 @@
|
||||
;; lib/minikanren/tests/iterate-no.sx — iterated relation application.
|
||||
|
||||
(define
|
||||
mk-nat
|
||||
(fn (n) (if (= n 0) :z (list :s (mk-nat (- n 1))))))
|
||||
|
||||
(mk-test
|
||||
"iterate-no-zero"
|
||||
(run*
|
||||
q
|
||||
(iterate-no
|
||||
(fn (a b) (== b (list :wrap a)))
|
||||
(mk-nat 0)
|
||||
:seed q))
|
||||
(list :seed))
|
||||
|
||||
(mk-test
|
||||
"iterate-no-three-wraps"
|
||||
(run*
|
||||
q
|
||||
(iterate-no (fn (a b) (== b (list :wrap a))) (mk-nat 3) :x q))
|
||||
(list (list :wrap (list :wrap (list :wrap :x)))))
|
||||
|
||||
(mk-test
|
||||
"iterate-no-succ-three-times"
|
||||
(run*
|
||||
q
|
||||
(iterate-no (fn (a b) (== b (list :s a))) (mk-nat 3) :z q))
|
||||
(list (mk-nat 3)))
|
||||
|
||||
(mk-test
|
||||
"iterate-no-with-list-cons"
|
||||
(run*
|
||||
q
|
||||
(iterate-no (fn (a b) (conso :a a b)) (mk-nat 4) (list) q))
|
||||
(list (list :a :a :a :a)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,38 +0,0 @@
|
||||
;; lib/minikanren/tests/lasto.sx — last-element + init-without-last.
|
||||
|
||||
(mk-test
|
||||
"lasto-singleton"
|
||||
(run* q (lasto (list 5) q))
|
||||
(list 5))
|
||||
(mk-test
|
||||
"lasto-multi"
|
||||
(run* q (lasto (list 1 2 3 4) q))
|
||||
(list 4))
|
||||
(mk-test "lasto-empty" (run* q (lasto (list) q)) (list))
|
||||
|
||||
(mk-test "lasto-strings" (run* q (lasto (list "a" "b" "c") q)) (list "c"))
|
||||
|
||||
(mk-test
|
||||
"init-o-multi"
|
||||
(run* q (init-o (list 1 2 3 4) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"init-o-singleton"
|
||||
(run* q (init-o (list 7) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test "init-o-empty" (run* q (init-o (list) q)) (list))
|
||||
|
||||
(mk-test
|
||||
"lasto-init-o-roundtrip"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(init last)
|
||||
(lasto (list 1 2 3 4) last)
|
||||
(init-o (list 1 2 3 4) init)
|
||||
(appendo init (list last) q)))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,61 +0,0 @@
|
||||
;; lib/minikanren/tests/latin.sx — 2x2 Latin square via ino + all-distincto.
|
||||
;;
|
||||
;; A 2x2 Latin square has 2 distinct fillings:
|
||||
;; ((1 2) (2 1)) and ((2 1) (1 2)).
|
||||
;; The 3x3 version has 12 fillings but takes minutes under naive search;
|
||||
;; full CLP(FD) (Phase 6 proper) would handle it in milliseconds.
|
||||
|
||||
(define
|
||||
latin-2x2
|
||||
(fn
|
||||
(cells)
|
||||
(let
|
||||
((c11 (nth cells 0))
|
||||
(c12 (nth cells 1))
|
||||
(c21 (nth cells 2))
|
||||
(c22 (nth cells 3))
|
||||
(dom (list 1 2)))
|
||||
(mk-conj
|
||||
(ino c11 dom)
|
||||
(ino c12 dom)
|
||||
(ino c21 dom)
|
||||
(ino c22 dom)
|
||||
(all-distincto (list c11 c12))
|
||||
(all-distincto (list c21 c22))
|
||||
(all-distincto (list c11 c21))
|
||||
(all-distincto (list c12 c22)))))) ;; col 2
|
||||
|
||||
(mk-test
|
||||
"latin-2x2-count"
|
||||
(let
|
||||
((squares (run* q (fresh (a b c d) (== q (list a b c d)) (latin-2x2 (list a b c d))))))
|
||||
(len squares))
|
||||
2)
|
||||
|
||||
(mk-test
|
||||
"latin-2x2-as-set"
|
||||
(let
|
||||
((squares (run* q (fresh (a b c d) (== q (list a b c d)) (latin-2x2 (list a b c d))))))
|
||||
(and
|
||||
(= (len squares) 2)
|
||||
(and
|
||||
(some
|
||||
(fn (s) (= s (list 1 2 2 1)))
|
||||
squares)
|
||||
(some
|
||||
(fn (s) (= s (list 2 1 1 2)))
|
||||
squares))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"latin-2x2-with-clue"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b c d)
|
||||
(== a 1)
|
||||
(== q (list a b c d))
|
||||
(latin-2x2 (list a b c d))))
|
||||
(list (list 1 2 2 1)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,77 +0,0 @@
|
||||
;; lib/minikanren/tests/laziness.sx — verify Zzz wrapping (in conde)
|
||||
;; lets infinitely-recursive relations produce finite prefixes via run-n.
|
||||
|
||||
;; --- a relation that has no base case but conde-protects via Zzz ---
|
||||
|
||||
(define
|
||||
listo-aux
|
||||
(fn
|
||||
(l)
|
||||
(conde ((nullo l)) ((fresh (a d) (conso a d l) (listo-aux d))))))
|
||||
|
||||
(mk-test
|
||||
"infinite-relation-truncates-via-run-n"
|
||||
(run 4 q (listo-aux q))
|
||||
(list
|
||||
(list)
|
||||
(list (make-symbol "_.0"))
|
||||
(list (make-symbol "_.0") (make-symbol "_.1"))
|
||||
(list (make-symbol "_.0") (make-symbol "_.1") (make-symbol "_.2"))))
|
||||
|
||||
;; --- two infinite generators interleaved via mk-disj must both produce
|
||||
;; answers (no starvation) — the fairness test ---
|
||||
|
||||
(define
|
||||
ones-gen
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((== l (list)))
|
||||
((fresh (d) (conso 1 d l) (ones-gen d))))))
|
||||
|
||||
(define
|
||||
twos-gen
|
||||
(fn
|
||||
(l)
|
||||
(conde
|
||||
((== l (list)))
|
||||
((fresh (d) (conso 2 d l) (twos-gen d))))))
|
||||
|
||||
(mk-test
|
||||
"interleaving-keeps-both-streams-alive"
|
||||
(let
|
||||
((res (run 4 q (mk-disj (ones-gen q) (twos-gen q)))))
|
||||
(and
|
||||
(= (len res) 4)
|
||||
(and
|
||||
(some
|
||||
(fn
|
||||
(x)
|
||||
(and
|
||||
(list? x)
|
||||
(and (not (empty? x)) (= (first x) 1))))
|
||||
res)
|
||||
(some
|
||||
(fn
|
||||
(x)
|
||||
(and
|
||||
(list? x)
|
||||
(and (not (empty? x)) (= (first x) 2))))
|
||||
res))))
|
||||
true)
|
||||
|
||||
;; --- run* terminates on a relation whose conde has finite base case
|
||||
;; reached from any starting point ---
|
||||
|
||||
(mk-test
|
||||
"run-star-terminates-on-bounded-relation"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(l)
|
||||
(== l (list 1 2 3))
|
||||
(listo l)
|
||||
(== q :ok)))
|
||||
(list :ok))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,28 +0,0 @@
|
||||
;; lib/minikanren/tests/lengtho-i.sx — integer-indexed length (fast).
|
||||
|
||||
(mk-test "lengtho-i-empty" (run* q (lengtho-i (list) q)) (list 0))
|
||||
(mk-test
|
||||
"lengtho-i-singleton"
|
||||
(run* q (lengtho-i (list :a) q))
|
||||
(list 1))
|
||||
(mk-test
|
||||
"lengtho-i-three"
|
||||
(run* q (lengtho-i (list 1 2 3) q))
|
||||
(list 3))
|
||||
(mk-test
|
||||
"lengtho-i-five"
|
||||
(run*
|
||||
q
|
||||
(lengtho-i
|
||||
(list 1 2 3 4 5)
|
||||
q))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"lengtho-i-mixed-types"
|
||||
(run*
|
||||
q
|
||||
(lengtho-i (list 1 "two" :three (list 4 5)) q))
|
||||
(list 4))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,126 +0,0 @@
|
||||
;; lib/minikanren/tests/list-relations.sx — rembero, assoco, nth-o, samelengtho.
|
||||
|
||||
;; --- rembero (remove first occurrence) ---
|
||||
|
||||
(mk-test
|
||||
"rembero-element-present"
|
||||
(run*
|
||||
q
|
||||
(rembero 2 (list 1 2 3 2) q))
|
||||
(list (list 1 3 2)))
|
||||
|
||||
(mk-test
|
||||
"rembero-element-not-present"
|
||||
(run* q (rembero 99 (list 1 2 3) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"rembero-empty"
|
||||
(run* q (rembero 1 (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"rembero-only-element"
|
||||
(run* q (rembero 5 (list 5) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"rembero-first-of-many"
|
||||
(run*
|
||||
q
|
||||
(rembero 1 (list 1 2 3 4) q))
|
||||
(list (list 2 3 4)))
|
||||
|
||||
;; --- assoco (alist lookup) ---
|
||||
|
||||
(define
|
||||
test-pairs
|
||||
(list
|
||||
(list "alice" 30)
|
||||
(list "bob" 25)
|
||||
(list "carol" 35)))
|
||||
|
||||
(mk-test
|
||||
"assoco-found"
|
||||
(run* q (assoco "bob" test-pairs q))
|
||||
(list 25))
|
||||
|
||||
(mk-test
|
||||
"assoco-first"
|
||||
(run* q (assoco "alice" test-pairs q))
|
||||
(list 30))
|
||||
|
||||
(mk-test "assoco-missing" (run* q (assoco "dave" test-pairs q)) (list))
|
||||
|
||||
(mk-test
|
||||
"assoco-find-keys-with-value"
|
||||
(run* q (assoco q test-pairs 25))
|
||||
(list "bob"))
|
||||
|
||||
;; --- nth-o (Peano-indexed access) ---
|
||||
|
||||
(mk-test
|
||||
"nth-o-zero"
|
||||
(run* q (nth-o :z (list 10 20 30) q))
|
||||
(list 10))
|
||||
|
||||
(mk-test
|
||||
"nth-o-one"
|
||||
(run* q (nth-o (list :s :z) (list 10 20 30) q))
|
||||
(list 20))
|
||||
|
||||
(mk-test
|
||||
"nth-o-two"
|
||||
(run*
|
||||
q
|
||||
(nth-o (list :s (list :s :z)) (list 10 20 30) q))
|
||||
(list 30))
|
||||
|
||||
(mk-test
|
||||
"nth-o-out-of-range"
|
||||
(run*
|
||||
q
|
||||
(nth-o
|
||||
(list :s (list :s (list :s :z)))
|
||||
(list 10 20 30)
|
||||
q))
|
||||
(list))
|
||||
|
||||
;; --- samelengtho ---
|
||||
|
||||
(mk-test
|
||||
"samelengtho-equal"
|
||||
(run*
|
||||
q
|
||||
(samelengtho (list 1 2 3) (list :a :b :c)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"samelengtho-different-fails"
|
||||
(run* q (samelengtho (list 1 2) (list :a :b :c)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"samelengtho-empty-equal"
|
||||
(run* q (samelengtho (list) (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"samelengtho-builds-vars"
|
||||
(run 1 q (samelengtho (list 1 2 3) q))
|
||||
(list (list (make-symbol "_.0") (make-symbol "_.1") (make-symbol "_.2"))))
|
||||
|
||||
(mk-test
|
||||
"samelengtho-enumerates-pairs"
|
||||
(run
|
||||
3
|
||||
q
|
||||
(fresh (l1 l2) (samelengtho l1 l2) (== q (list l1 l2))))
|
||||
(list
|
||||
(list (list) (list))
|
||||
(list (list (make-symbol "_.0")) (list (make-symbol "_.1")))
|
||||
(list
|
||||
(list (make-symbol "_.0") (make-symbol "_.1"))
|
||||
(list (make-symbol "_.2") (make-symbol "_.3")))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,62 +0,0 @@
|
||||
;; lib/minikanren/tests/mapo.sx — relational map.
|
||||
|
||||
(mk-test
|
||||
"mapo-identity"
|
||||
(run*
|
||||
q
|
||||
(mapo (fn (a b) (== a b)) (list 1 2 3) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"mapo-tag-each"
|
||||
(run*
|
||||
q
|
||||
(mapo
|
||||
(fn (a b) (== b (list :tag a)))
|
||||
(list 1 2 3)
|
||||
q))
|
||||
(list
|
||||
(list
|
||||
(list :tag 1)
|
||||
(list :tag 2)
|
||||
(list :tag 3))))
|
||||
|
||||
(mk-test
|
||||
"mapo-backward"
|
||||
(run*
|
||||
q
|
||||
(mapo (fn (a b) (== a b)) q (list 1 2 3)))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"mapo-empty"
|
||||
(run* q (mapo (fn (a b) (== a b)) (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"mapo-duplicate"
|
||||
(run* q (mapo (fn (a b) (== b (list a a))) (list :x :y) q))
|
||||
(list (list (list :x :x) (list :y :y))))
|
||||
|
||||
(mk-test
|
||||
"mapo-different-length-fails"
|
||||
(run*
|
||||
q
|
||||
(mapo
|
||||
(fn (a b) (== a b))
|
||||
(list 1 2)
|
||||
(list 1 2 3)))
|
||||
(list))
|
||||
|
||||
;; mapo + arithmetic via intarith
|
||||
(mk-test
|
||||
"mapo-square-each"
|
||||
(run*
|
||||
q
|
||||
(mapo
|
||||
(fn (a b) (*o-i a a b))
|
||||
(list 1 2 3 4)
|
||||
q))
|
||||
(list (list 1 4 9 16)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,138 +0,0 @@
|
||||
;; lib/minikanren/tests/matche.sx — Phase 5 piece D tests for `matche`.
|
||||
|
||||
;; --- literal patterns ---
|
||||
|
||||
(mk-test
|
||||
"matche-literal-number"
|
||||
(run* q (matche q (1 (== q 1))))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"matche-literal-string"
|
||||
(run* q (matche q ("hello" (== q "hello"))))
|
||||
(list "hello"))
|
||||
|
||||
(mk-test
|
||||
"matche-literal-no-clause-matches"
|
||||
(run*
|
||||
q
|
||||
(matche 7 (1 (== q :a)) (2 (== q :b))))
|
||||
(list))
|
||||
|
||||
;; --- variable patterns ---
|
||||
|
||||
(mk-test
|
||||
"matche-symbol-pattern"
|
||||
(run* q (fresh (x) (== x 99) (matche x (a (== q a)))))
|
||||
(list 99))
|
||||
|
||||
(mk-test
|
||||
"matche-wildcard"
|
||||
(run* q (fresh (x) (== x 7) (matche x (_ (== q :any)))))
|
||||
(list :any))
|
||||
|
||||
;; --- list patterns ---
|
||||
|
||||
(mk-test
|
||||
"matche-empty-list"
|
||||
(run* q (matche (list) (() (== q :ok))))
|
||||
(list :ok))
|
||||
|
||||
(mk-test
|
||||
"matche-pair-binds"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 1 2))
|
||||
(matche x ((a b) (== q (list b a))))))
|
||||
(list (list 2 1)))
|
||||
|
||||
(mk-test
|
||||
"matche-triple-binds"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 1 2 3))
|
||||
(matche x ((a b c) (== q (list :sum a b c))))))
|
||||
(list (list :sum 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"matche-mixed-literal-and-var"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 1 99 3))
|
||||
(matche x ((1 m 3) (== q m)))))
|
||||
(list 99))
|
||||
|
||||
;; --- multi-clause dispatch ---
|
||||
|
||||
(mk-test
|
||||
"matche-multi-clause-shape"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 5 6))
|
||||
(matche
|
||||
x
|
||||
(() (== q :empty))
|
||||
((a) (== q (list :one a)))
|
||||
((a b) (== q (list :two a b))))))
|
||||
(list (list :two 5 6)))
|
||||
|
||||
(mk-test
|
||||
"matche-three-shapes-via-fresh"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(matche
|
||||
x
|
||||
(() (== q :empty))
|
||||
((a) (== q (list :one a)))
|
||||
((a b) (== q (list :two a b))))))
|
||||
(list
|
||||
:empty (list :one (make-symbol "_.0"))
|
||||
(list :two (make-symbol "_.0") (make-symbol "_.1"))))
|
||||
|
||||
;; --- nested patterns ---
|
||||
|
||||
(mk-test
|
||||
"matche-nested"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(==
|
||||
x
|
||||
(list (list 1 2) (list 3 4)))
|
||||
(matche x (((a b) (c d)) (== q (list a b c d))))))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
;; --- repeated var names create the same fresh var → must unify ---
|
||||
|
||||
(mk-test
|
||||
"matche-repeated-var-implies-equality"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 7 7))
|
||||
(matche x ((a a) (== q a)))))
|
||||
(list 7))
|
||||
|
||||
(mk-test
|
||||
"matche-repeated-var-mismatch-fails"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(== x (list 7 8))
|
||||
(matche x ((a a) (== q a)))))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,49 +0,0 @@
|
||||
;; lib/minikanren/tests/minmax.sx — mino + maxo via intarith.
|
||||
|
||||
(mk-test
|
||||
"mino-singleton"
|
||||
(run* q (mino (list 7) q))
|
||||
(list 7))
|
||||
(mk-test
|
||||
"mino-of-3"
|
||||
(run* q (mino (list 5 1 3) q))
|
||||
(list 1))
|
||||
(mk-test
|
||||
"mino-of-5"
|
||||
(run*
|
||||
q
|
||||
(mino (list 5 1 3 2 4) q))
|
||||
(list 1))
|
||||
(mk-test
|
||||
"mino-with-dups"
|
||||
(run* q (mino (list 3 3 3) q))
|
||||
(list 3))
|
||||
(mk-test "mino-empty-fails" (run* q (mino (list) q)) (list))
|
||||
|
||||
(mk-test
|
||||
"maxo-singleton"
|
||||
(run* q (maxo (list 7) q))
|
||||
(list 7))
|
||||
(mk-test
|
||||
"maxo-of-5"
|
||||
(run*
|
||||
q
|
||||
(maxo (list 5 1 3 2 4) q))
|
||||
(list 5))
|
||||
(mk-test
|
||||
"maxo-of-negs"
|
||||
(run* q (maxo (list -5 -1 -3) q))
|
||||
(list -1))
|
||||
|
||||
(mk-test
|
||||
"min-and-max-of-list"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(mn mx)
|
||||
(mino (list 5 1 3 2 4) mn)
|
||||
(maxo (list 5 1 3 2 4) mx)
|
||||
(== q (list mn mx))))
|
||||
(list (list 1 5)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,50 +0,0 @@
|
||||
;; lib/minikanren/tests/nafc.sx — Phase 5 piece C tests for `nafc`.
|
||||
|
||||
(mk-test
|
||||
"nafc-failed-goal-succeeds"
|
||||
(run* q (nafc (== 1 2)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"nafc-successful-goal-fails"
|
||||
(run* q (nafc (== 1 1)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"nafc-double-negation"
|
||||
(run* q (nafc (nafc (== 1 1))))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"nafc-with-conde-no-clauses-succeed"
|
||||
(run*
|
||||
q
|
||||
(nafc
|
||||
(conde ((== 1 2)) ((== 3 4)))))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"nafc-with-conde-some-clause-succeeds-fails"
|
||||
(run*
|
||||
q
|
||||
(nafc
|
||||
(conde ((== 1 1)) ((== 3 4)))))
|
||||
(list))
|
||||
|
||||
;; --- composing nafc with == as a guard ---
|
||||
|
||||
(mk-test
|
||||
"nafc-as-guard"
|
||||
(run*
|
||||
q
|
||||
(fresh (x) (== x 5) (nafc (== x 99)) (== q x)))
|
||||
(list 5))
|
||||
|
||||
(mk-test
|
||||
"nafc-guard-blocking"
|
||||
(run*
|
||||
q
|
||||
(fresh (x) (== x 5) (nafc (== x 5)) (== q x)))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,29 +0,0 @@
|
||||
;; lib/minikanren/tests/not-membero.sx — relational "not in list".
|
||||
|
||||
(mk-test
|
||||
"not-membero-absent"
|
||||
(run* q (not-membero 99 (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"not-membero-present"
|
||||
(run* q (not-membero 2 (list 1 2 3)))
|
||||
(list))
|
||||
(mk-test
|
||||
"not-membero-empty"
|
||||
(run* q (not-membero 1 (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"not-membero-as-filter"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x)
|
||||
(membero
|
||||
x
|
||||
(list 1 2 3 4 5))
|
||||
(not-membero x (list 2 4))
|
||||
(== q x)))
|
||||
(list 1 3 5))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,31 +0,0 @@
|
||||
;; lib/minikanren/tests/nub-o.sx — relational dedupe (keep last occurrence).
|
||||
|
||||
(mk-test "nub-o-empty" (run* q (nub-o (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"nub-o-no-duplicates"
|
||||
(run* q (nub-o (list 1 2 3) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"nub-o-with-duplicates"
|
||||
(run*
|
||||
q
|
||||
(nub-o
|
||||
(list 1 2 1 3 2 4)
|
||||
q))
|
||||
(list (list 1 3 2 4)))
|
||||
|
||||
(mk-test
|
||||
"nub-o-all-same"
|
||||
(let
|
||||
((res (run* q (nub-o (list 1 1 1) q))))
|
||||
(every? (fn (r) (= r (list 1))) res))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"nub-o-keeps-last"
|
||||
(run* q (nub-o (list 1 2 1) q))
|
||||
(list (list 2 1)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,41 +0,0 @@
|
||||
;; lib/minikanren/tests/pairlisto.sx — zip two lists into pair list.
|
||||
|
||||
(mk-test
|
||||
"pairlisto-empty"
|
||||
(run* q (pairlisto (list) (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"pairlisto-equal-lengths"
|
||||
(run*
|
||||
q
|
||||
(pairlisto (list 1 2 3) (list :a :b :c) q))
|
||||
(list
|
||||
(list (list 1 :a) (list 2 :b) (list 3 :c))))
|
||||
|
||||
(mk-test
|
||||
"pairlisto-recover-l1"
|
||||
(run*
|
||||
q
|
||||
(pairlisto
|
||||
q
|
||||
(list :a :b :c)
|
||||
(list (list 10 :a) (list 20 :b) (list 30 :c))))
|
||||
(list (list 10 20 30)))
|
||||
|
||||
(mk-test
|
||||
"pairlisto-recover-l2"
|
||||
(run*
|
||||
q
|
||||
(pairlisto
|
||||
(list 1 2 3)
|
||||
q
|
||||
(list (list 1 :x) (list 2 :y) (list 3 :z))))
|
||||
(list (list :x :y :z)))
|
||||
|
||||
(mk-test
|
||||
"pairlisto-different-lengths-fails"
|
||||
(run* q (pairlisto (list 1 2) (list :a :b :c) q))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,44 +0,0 @@
|
||||
;; lib/minikanren/tests/palindromeo.sx — palindromic list relation.
|
||||
|
||||
(mk-test
|
||||
"palindromeo-empty"
|
||||
(run* q (palindromeo (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-singleton"
|
||||
(run* q (palindromeo (list :a)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-pair-equal"
|
||||
(run* q (palindromeo (list 1 1)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-pair-unequal-fails"
|
||||
(run* q (palindromeo (list 1 2)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-five-yes"
|
||||
(run*
|
||||
q
|
||||
(palindromeo
|
||||
(list 1 2 3 2 1)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-five-no"
|
||||
(run*
|
||||
q
|
||||
(palindromeo
|
||||
(list 1 2 3 4 5)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"palindromeo-strings"
|
||||
(run* q (palindromeo (list "a" "b" "a")))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,58 +0,0 @@
|
||||
;; lib/minikanren/tests/parity.sx — eveno + oddo Peano predicates.
|
||||
|
||||
(define
|
||||
mk-nat
|
||||
(fn (n) (if (= n 0) :z (list :s (mk-nat (- n 1))))))
|
||||
|
||||
(mk-test "eveno-zero" (run* q (eveno :z)) (list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"eveno-2"
|
||||
(run* q (eveno (mk-nat 2)))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"eveno-4"
|
||||
(run* q (eveno (mk-nat 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "eveno-1-fails" (run* q (eveno (mk-nat 1))) (list))
|
||||
(mk-test "eveno-3-fails" (run* q (eveno (mk-nat 3))) (list))
|
||||
|
||||
(mk-test
|
||||
"oddo-1"
|
||||
(run* q (oddo (mk-nat 1)))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"oddo-3"
|
||||
(run* q (oddo (mk-nat 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "oddo-zero-fails" (run* q (oddo :z)) (list))
|
||||
(mk-test "oddo-2-fails" (run* q (oddo (mk-nat 2))) (list))
|
||||
|
||||
;; Enumerate small evens.
|
||||
(mk-test
|
||||
"eveno-enumerates"
|
||||
(run 4 q (eveno q))
|
||||
(list
|
||||
(mk-nat 0)
|
||||
(mk-nat 2)
|
||||
(mk-nat 4)
|
||||
(mk-nat 6)))
|
||||
|
||||
;; Enumerate small odds.
|
||||
(mk-test
|
||||
"oddo-enumerates"
|
||||
(run 4 q (oddo q))
|
||||
(list
|
||||
(mk-nat 1)
|
||||
(mk-nat 3)
|
||||
(mk-nat 5)
|
||||
(mk-nat 7)))
|
||||
|
||||
;; A number is even XOR odd (no overlap).
|
||||
(mk-test
|
||||
"even-odd-no-overlap"
|
||||
(run*
|
||||
q
|
||||
(mk-conj (eveno (mk-nat 4)) (oddo (mk-nat 4))))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,75 +0,0 @@
|
||||
;; lib/minikanren/tests/partitiono.sx — partition list by predicate.
|
||||
|
||||
(mk-test
|
||||
"partitiono-empty"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(yes no)
|
||||
(partitiono (fn (x) (== x 1)) (list) yes no)
|
||||
(== q (list yes no))))
|
||||
(list (list (list) (list))))
|
||||
|
||||
(mk-test
|
||||
"partitiono-by-equality"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(yes no)
|
||||
(partitiono
|
||||
(fn (x) (== x 2))
|
||||
(list 1 2 3 2 4)
|
||||
yes
|
||||
no)
|
||||
(== q (list yes no))))
|
||||
(list
|
||||
(list
|
||||
(list 2 2)
|
||||
(list 1 3 4))))
|
||||
|
||||
(mk-test
|
||||
"partitiono-by-numeric-pred"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(yes no)
|
||||
(partitiono
|
||||
(fn (x) (lto-i x 5))
|
||||
(list 1 7 2 8 3)
|
||||
yes
|
||||
no)
|
||||
(== q (list yes no))))
|
||||
(list
|
||||
(list
|
||||
(list 1 2 3)
|
||||
(list 7 8))))
|
||||
|
||||
(mk-test
|
||||
"partitiono-all-yes"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(yes no)
|
||||
(partitiono
|
||||
(fn (x) (lto-i x 100))
|
||||
(list 1 2 3)
|
||||
yes
|
||||
no)
|
||||
(== q (list yes no))))
|
||||
(list (list (list 1 2 3) (list))))
|
||||
|
||||
(mk-test
|
||||
"partitiono-all-no"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(yes no)
|
||||
(partitiono
|
||||
(fn (x) (lto-i 100 x))
|
||||
(list 1 2 3)
|
||||
yes
|
||||
no)
|
||||
(== q (list yes no))))
|
||||
(list (list (list) (list 1 2 3))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,40 +0,0 @@
|
||||
;; lib/minikanren/tests/path-cycle-free.sx — cycle-free reachability search.
|
||||
;;
|
||||
;; Threads a "visited" accumulator through the recursion, using nafc +
|
||||
;; membero to prevent revisiting nodes. Demonstrates how to make the
|
||||
;; cyclic-graph divergence problem (see tests/cyclic-graph.sx) tractable
|
||||
;; for graphs with cycles, without invoking Phase-7 tabling.
|
||||
|
||||
(define
|
||||
cf-edges
|
||||
(list (list :a :b) (list :b :a) (list :b :c) (list :c :d) (list :d :a))) ; another cycle
|
||||
|
||||
(define cf-edgeo (fn (from to) (membero (list from to) cf-edges)))
|
||||
|
||||
(define
|
||||
patho-no-cycles
|
||||
(fn
|
||||
(x y visited path)
|
||||
(conde
|
||||
((cf-edgeo x y) (nafc (membero y visited)) (== path (list x y)))
|
||||
((fresh (z mid v-prime) (cf-edgeo x z) (nafc (membero z visited)) (conso z visited v-prime) (patho-no-cycles z y v-prime mid) (conso x mid path))))))
|
||||
|
||||
(define cf-patho (fn (x y path) (patho-no-cycles x y (list x) path)))
|
||||
|
||||
(mk-test
|
||||
"cycle-free-finds-finitely"
|
||||
(let
|
||||
((paths (run* q (cf-patho :a :d q))))
|
||||
(and
|
||||
(>= (len paths) 1)
|
||||
(every? (fn (p) (and (= (first p) :a) (= (last p) :d))) paths)))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"cycle-free-direct-edge"
|
||||
(run* q (cf-patho :a :b q))
|
||||
(list (list :a :b)))
|
||||
|
||||
(mk-test "cycle-free-no-self-loop" (run* q (cf-patho :a :a q)) (list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,119 +0,0 @@
|
||||
;; lib/minikanren/tests/peano.sx — Peano arithmetic.
|
||||
;;
|
||||
;; Builds Peano numbers via a host-side helper so tests stay readable.
|
||||
;; (mk-nat 3) → (:s (:s (:s :z))).
|
||||
|
||||
(define
|
||||
mk-nat
|
||||
(fn (n) (if (= n 0) :z (list :s (mk-nat (- n 1))))))
|
||||
|
||||
;; --- zeroo ---
|
||||
|
||||
(mk-test
|
||||
"zeroo-zero-succeeds"
|
||||
(run* q (zeroo :z))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test
|
||||
"zeroo-non-zero-fails"
|
||||
(run* q (zeroo (mk-nat 1)))
|
||||
(list))
|
||||
|
||||
;; --- pluso forward ---
|
||||
|
||||
(mk-test
|
||||
"pluso-forward-2-3"
|
||||
(run* q (pluso (mk-nat 2) (mk-nat 3) q))
|
||||
(list (mk-nat 5)))
|
||||
|
||||
(mk-test "pluso-forward-zero-zero" (run* q (pluso :z :z q)) (list :z))
|
||||
|
||||
(mk-test
|
||||
"pluso-forward-zero-n"
|
||||
(run* q (pluso :z (mk-nat 4) q))
|
||||
(list (mk-nat 4)))
|
||||
|
||||
(mk-test
|
||||
"pluso-forward-n-zero"
|
||||
(run* q (pluso (mk-nat 4) :z q))
|
||||
(list (mk-nat 4)))
|
||||
|
||||
;; --- pluso backward ---
|
||||
|
||||
(mk-test
|
||||
"pluso-recover-augend"
|
||||
(run* q (pluso q (mk-nat 2) (mk-nat 5)))
|
||||
(list (mk-nat 3)))
|
||||
|
||||
(mk-test
|
||||
"pluso-recover-addend"
|
||||
(run* q (pluso (mk-nat 2) q (mk-nat 5)))
|
||||
(list (mk-nat 3)))
|
||||
|
||||
(mk-test
|
||||
"pluso-enumerate-pairs-summing-to-3"
|
||||
(run*
|
||||
q
|
||||
(fresh (a b) (pluso a b (mk-nat 3)) (== q (list a b))))
|
||||
(list
|
||||
(list :z (mk-nat 3))
|
||||
(list (mk-nat 1) (mk-nat 2))
|
||||
(list (mk-nat 2) (mk-nat 1))
|
||||
(list (mk-nat 3) :z)))
|
||||
|
||||
;; --- minuso ---
|
||||
|
||||
(mk-test
|
||||
"minuso-5-2-3"
|
||||
(run* q (minuso (mk-nat 5) (mk-nat 2) q))
|
||||
(list (mk-nat 3)))
|
||||
|
||||
(mk-test
|
||||
"minuso-n-n-zero"
|
||||
(run* q (minuso (mk-nat 7) (mk-nat 7) q))
|
||||
(list :z))
|
||||
|
||||
;; --- *o ---
|
||||
|
||||
(mk-test
|
||||
"times-2-3"
|
||||
(run* q (*o (mk-nat 2) (mk-nat 3) q))
|
||||
(list (mk-nat 6)))
|
||||
|
||||
(mk-test
|
||||
"times-zero-anything-zero"
|
||||
(run* q (*o :z (mk-nat 99) q))
|
||||
(list :z))
|
||||
|
||||
(mk-test
|
||||
"times-3-4"
|
||||
(run* q (*o (mk-nat 3) (mk-nat 4) q))
|
||||
(list (mk-nat 12)))
|
||||
|
||||
;; --- lteo / lto ---
|
||||
|
||||
(mk-test
|
||||
"lteo-success"
|
||||
(run 1 q (lteo (mk-nat 2) (mk-nat 5)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"lteo-equal-success"
|
||||
(run 1 q (lteo (mk-nat 3) (mk-nat 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"lteo-greater-fails"
|
||||
(run* q (lteo (mk-nat 5) (mk-nat 2)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"lto-strict-success"
|
||||
(run 1 q (lto (mk-nat 2) (mk-nat 5)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"lto-equal-fails"
|
||||
(run* q (lto (mk-nat 3) (mk-nat 3)))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,87 +0,0 @@
|
||||
;; lib/minikanren/tests/predicates.sx — everyo, someo.
|
||||
|
||||
;; --- everyo ---
|
||||
|
||||
(mk-test
|
||||
"everyo-empty-trivially-true"
|
||||
(run* q (everyo (fn (x) (== x 1)) (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"everyo-all-match"
|
||||
(run*
|
||||
q
|
||||
(everyo
|
||||
(fn (x) (== x 1))
|
||||
(list 1 1 1)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"everyo-some-mismatch"
|
||||
(run*
|
||||
q
|
||||
(everyo
|
||||
(fn (x) (== x 1))
|
||||
(list 1 2 1)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"everyo-with-intarith"
|
||||
(run*
|
||||
q
|
||||
(everyo
|
||||
(fn (x) (lto-i x 10))
|
||||
(list 1 5 9)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"everyo-with-intarith-fail"
|
||||
(run*
|
||||
q
|
||||
(everyo
|
||||
(fn (x) (lto-i x 5))
|
||||
(list 1 5 9)))
|
||||
(list))
|
||||
|
||||
;; --- someo ---
|
||||
|
||||
(mk-test
|
||||
"someo-finds-element"
|
||||
(run*
|
||||
q
|
||||
(someo
|
||||
(fn (x) (== x 2))
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"someo-not-found"
|
||||
(run*
|
||||
q
|
||||
(someo
|
||||
(fn (x) (== x 99))
|
||||
(list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"someo-empty-fails"
|
||||
(run* q (someo (fn (x) (== x 1)) (list)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"someo-multiple-matches-yields-multiple"
|
||||
(let
|
||||
((res (run* q (fresh (x) (someo (fn (y) (== y x)) (list 1 2 1)) (== q x)))))
|
||||
(len res))
|
||||
3)
|
||||
|
||||
(mk-test
|
||||
"someo-with-intarith"
|
||||
(run*
|
||||
q
|
||||
(someo
|
||||
(fn (x) (lto-i 100 x))
|
||||
(list 5 50 200)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,76 +0,0 @@
|
||||
;; lib/minikanren/tests/prefix-suffix.sx — appendo-derived sublist relations.
|
||||
|
||||
(mk-test
|
||||
"prefixo-empty"
|
||||
(run* q (prefixo (list) (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"prefixo-full"
|
||||
(run*
|
||||
q
|
||||
(prefixo
|
||||
(list 1 2 3)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"prefixo-partial"
|
||||
(run*
|
||||
q
|
||||
(prefixo
|
||||
(list 1 2)
|
||||
(list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"prefixo-mismatch-fails"
|
||||
(run*
|
||||
q
|
||||
(prefixo
|
||||
(list 1 3)
|
||||
(list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"prefixo-enumerates-all"
|
||||
(run* q (prefixo q (list 1 2 3)))
|
||||
(list
|
||||
(list)
|
||||
(list 1)
|
||||
(list 1 2)
|
||||
(list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"suffixo-empty"
|
||||
(run* q (suffixo (list) (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"suffixo-full"
|
||||
(run*
|
||||
q
|
||||
(suffixo
|
||||
(list 1 2 3)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"suffixo-partial"
|
||||
(run*
|
||||
q
|
||||
(suffixo
|
||||
(list 2 3)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"suffixo-enumerates-all"
|
||||
(run* q (suffixo q (list 1 2 3)))
|
||||
(list
|
||||
(list 1 2 3)
|
||||
(list 2 3)
|
||||
(list 3)
|
||||
(list)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,60 +0,0 @@
|
||||
;; lib/minikanren/tests/project.sx — Phase 5 piece B tests for `project`.
|
||||
|
||||
;; --- project rebinds vars to ground values for SX use ---
|
||||
|
||||
(mk-test
|
||||
"project-square-via-host"
|
||||
(run* q (fresh (n) (== n 5) (project (n) (== q (* n n)))))
|
||||
(list 25))
|
||||
|
||||
(mk-test
|
||||
"project-multi-vars"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(a b)
|
||||
(== a 3)
|
||||
(== b 4)
|
||||
(project (a b) (== q (+ a b)))))
|
||||
(list 7))
|
||||
|
||||
(mk-test
|
||||
"project-with-string-host-op"
|
||||
(run* q (fresh (s) (== s "hello") (project (s) (== q (str s "!")))))
|
||||
(list "hello!"))
|
||||
|
||||
;; --- project nested inside conde ---
|
||||
|
||||
(mk-test
|
||||
"project-inside-conde"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(n)
|
||||
(conde ((== n 3)) ((== n 4)))
|
||||
(project (n) (== q (* n 10)))))
|
||||
(list 30 40))
|
||||
|
||||
;; --- project body can be multiple goals (mk-conj'd) ---
|
||||
|
||||
(mk-test
|
||||
"project-multi-goal-body"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(n)
|
||||
(== n 7)
|
||||
(project (n) (== q (+ n 1)) (== q (+ n 1)))))
|
||||
(list 8))
|
||||
|
||||
(mk-test
|
||||
"project-multi-goal-body-conflict"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(n)
|
||||
(== n 7)
|
||||
(project (n) (== q (+ n 1)) (== q (+ n 2)))))
|
||||
(list))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,36 +0,0 @@
|
||||
;; lib/minikanren/tests/pythag.sx — Pythagorean triple search.
|
||||
;;
|
||||
;; Uses ino + intarith goals to find triples (a, b, c) with
|
||||
;; a, b, c ∈ [1..N], a ≤ b, a² + b² = c². With intarith escapes
|
||||
;; the search runs at host-arithmetic speed.
|
||||
|
||||
(define
|
||||
digits-1-10
|
||||
(list
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6
|
||||
7
|
||||
8
|
||||
9
|
||||
10))
|
||||
|
||||
(mk-test
|
||||
"pythag-triples-1-to-10"
|
||||
(let
|
||||
((triples (run* q (fresh (a b c a-sq b-sq sum c-sq) (ino a digits-1-10) (ino b digits-1-10) (ino c digits-1-10) (lteo-i a b) (*o-i a a a-sq) (*o-i b b b-sq) (*o-i c c c-sq) (pluso-i a-sq b-sq sum) (== sum c-sq) (== q (list a b c))))))
|
||||
(and
|
||||
(= (len triples) 2)
|
||||
(and
|
||||
(some
|
||||
(fn (t) (= t (list 3 4 5)))
|
||||
triples)
|
||||
(some
|
||||
(fn (t) (= t (list 6 8 10)))
|
||||
triples))))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,97 +0,0 @@
|
||||
;; lib/minikanren/tests/queens-fd.sx — N-queens via CLP(FD).
|
||||
;;
|
||||
;; Native FD propagation makes N-queens tractable: 4-queens finds both
|
||||
;; solutions instantly; 5-queens finds all 10 in seconds. Compare with
|
||||
;; the naive enumerate-then-filter version in queens.sx, which struggles
|
||||
;; past N=4.
|
||||
|
||||
(define
|
||||
fd-no-diag
|
||||
(fn
|
||||
(ci cj k)
|
||||
(fresh
|
||||
(a b)
|
||||
(fd-plus cj k a)
|
||||
(fd-plus ci k b)
|
||||
(fd-neq ci a)
|
||||
(fd-neq cj b))))
|
||||
|
||||
(define
|
||||
n-queens-4-fd
|
||||
(fn
|
||||
(cs)
|
||||
(let
|
||||
((c1 (nth cs 0))
|
||||
(c2 (nth cs 1))
|
||||
(c3 (nth cs 2))
|
||||
(c4 (nth cs 3)))
|
||||
(mk-conj
|
||||
(fd-in c1 (list 1 2 3 4))
|
||||
(fd-in c2 (list 1 2 3 4))
|
||||
(fd-in c3 (list 1 2 3 4))
|
||||
(fd-in c4 (list 1 2 3 4))
|
||||
(fd-distinct cs)
|
||||
(fd-no-diag c1 c2 1)
|
||||
(fd-no-diag c1 c3 2)
|
||||
(fd-no-diag c1 c4 3)
|
||||
(fd-no-diag c2 c3 1)
|
||||
(fd-no-diag c2 c4 2)
|
||||
(fd-no-diag c3 c4 1)
|
||||
(fd-label cs)))))
|
||||
|
||||
(define
|
||||
n-queens-5-fd
|
||||
(fn
|
||||
(cs)
|
||||
(let
|
||||
((c1 (nth cs 0))
|
||||
(c2 (nth cs 1))
|
||||
(c3 (nth cs 2))
|
||||
(c4 (nth cs 3))
|
||||
(c5 (nth cs 4)))
|
||||
(mk-conj
|
||||
(fd-in
|
||||
c1
|
||||
(list 1 2 3 4 5))
|
||||
(fd-in
|
||||
c2
|
||||
(list 1 2 3 4 5))
|
||||
(fd-in
|
||||
c3
|
||||
(list 1 2 3 4 5))
|
||||
(fd-in
|
||||
c4
|
||||
(list 1 2 3 4 5))
|
||||
(fd-in
|
||||
c5
|
||||
(list 1 2 3 4 5))
|
||||
(fd-distinct cs)
|
||||
(fd-no-diag c1 c2 1)
|
||||
(fd-no-diag c1 c3 2)
|
||||
(fd-no-diag c1 c4 3)
|
||||
(fd-no-diag c1 c5 4)
|
||||
(fd-no-diag c2 c3 1)
|
||||
(fd-no-diag c2 c4 2)
|
||||
(fd-no-diag c2 c5 3)
|
||||
(fd-no-diag c3 c4 1)
|
||||
(fd-no-diag c3 c5 2)
|
||||
(fd-no-diag c4 c5 1)
|
||||
(fd-label cs)))))
|
||||
|
||||
(mk-test
|
||||
"n-queens-4-fd-two-solutions"
|
||||
(run*
|
||||
q
|
||||
(fresh (a b c d) (== q (list a b c d)) (n-queens-4-fd (list a b c d))))
|
||||
(list
|
||||
(list 2 4 1 3)
|
||||
(list 3 1 4 2)))
|
||||
|
||||
(mk-test
|
||||
"n-queens-5-fd-ten-solutions"
|
||||
(let
|
||||
((sols (run* q (fresh (a b c d e) (== q (list a b c d e)) (n-queens-5-fd (list a b c d e))))))
|
||||
(= (len sols) 10))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,45 +0,0 @@
|
||||
;; lib/minikanren/tests/queens.sx — N-queens, the classic miniKanren benchmark.
|
||||
|
||||
;; --- safe-diag (helper) ---
|
||||
|
||||
(mk-test
|
||||
"safe-diag-different-cols-different-distance"
|
||||
(run* q (safe-diag 1 4 2))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"safe-diag-same-distance-fails"
|
||||
(run* q (safe-diag 1 4 3))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"safe-diag-same-distance-other-direction-fails"
|
||||
(run* q (safe-diag 4 1 3))
|
||||
(list))
|
||||
|
||||
;; --- ino-each / range ---
|
||||
|
||||
(mk-test
|
||||
"range-1-to-4"
|
||||
(range-1-to-n 4)
|
||||
(list 1 2 3 4))
|
||||
(mk-test "range-empty" (range-1-to-n 0) (list))
|
||||
|
||||
;; --- 4-queens: two solutions ---
|
||||
|
||||
(mk-test
|
||||
"queens-4"
|
||||
(let
|
||||
((sols (run* q (fresh (a b c d) (== q (list a b c d)) (queens-cols (list a b c d) 4)))))
|
||||
(and
|
||||
(= (len sols) 2)
|
||||
(and
|
||||
(some
|
||||
(fn (s) (= s (list 2 4 1 3)))
|
||||
sols)
|
||||
(some
|
||||
(fn (s) (= s (list 3 1 4 2)))
|
||||
sols))))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,90 +0,0 @@
|
||||
;; lib/minikanren/tests/rdb.sx — relational database queries.
|
||||
;;
|
||||
;; Demonstrates how miniKanren can serve as a Datalog-style query engine
|
||||
;; over fact tables. Tables are SX lists of tuples; the relation just
|
||||
;; wraps `membero` over the table.
|
||||
|
||||
(define
|
||||
rdb-employees
|
||||
(list
|
||||
(list "alice" "engineering" 100000)
|
||||
(list "bob" "marketing" 80000)
|
||||
(list "carol" "engineering" 90000)
|
||||
(list "dave" "engineering" 85000)
|
||||
(list "eve" "sales" 75000)))
|
||||
|
||||
(define
|
||||
rdb-projects
|
||||
(list
|
||||
(list "alice" "compiler")
|
||||
(list "carol" "compiler")
|
||||
(list "dave" "runtime")
|
||||
(list "alice" "runtime")
|
||||
(list "eve" "outreach")))
|
||||
|
||||
;; Relation views over the tables.
|
||||
|
||||
(define
|
||||
employees
|
||||
(fn (name dept salary) (membero (list name dept salary) rdb-employees)))
|
||||
|
||||
(define
|
||||
on-project
|
||||
(fn (name project) (membero (list name project) rdb-projects)))
|
||||
|
||||
;; --- queries ---
|
||||
|
||||
(mk-test
|
||||
"rdb-engineering-staff"
|
||||
(let
|
||||
((res (run* q (fresh (n s) (employees n "engineering" s) (== q n)))))
|
||||
(and
|
||||
(= (len res) 3)
|
||||
(and
|
||||
(some (fn (n) (= n "alice")) res)
|
||||
(and
|
||||
(some (fn (n) (= n "carol")) res)
|
||||
(some (fn (n) (= n "dave")) res)))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"rdb-high-salary"
|
||||
(let
|
||||
((res (run* q (fresh (n d s) (employees n d s) (lto-i 85000 s) (== q (list n s))))))
|
||||
(and
|
||||
(= (len res) 2)
|
||||
(and
|
||||
(some (fn (r) (= r (list "alice" 100000))) res)
|
||||
(some (fn (r) (= r (list "carol" 90000))) res))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"rdb-join-employee-project"
|
||||
(let
|
||||
((res (run* q (fresh (n d s) (employees n d s) (on-project n "compiler") (== q n)))))
|
||||
(and
|
||||
(= (len res) 2)
|
||||
(and
|
||||
(some (fn (n) (= n "alice")) res)
|
||||
(some (fn (n) (= n "carol")) res))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"rdb-engineers-on-runtime"
|
||||
(let
|
||||
((res (run* q (fresh (n s) (employees n "engineering" s) (on-project n "runtime") (== q n)))))
|
||||
(and
|
||||
(= (len res) 2)
|
||||
(and
|
||||
(some (fn (n) (= n "alice")) res)
|
||||
(some (fn (n) (= n "dave")) res))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"rdb-people-on-multiple-projects"
|
||||
(let
|
||||
((res (run* q (fresh (n p1 p2) (on-project n p1) (on-project n p2) (nafc (== p1 p2)) (== q n)))))
|
||||
(some (fn (n) (= n "alice")) res))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,291 +0,0 @@
|
||||
;; lib/minikanren/tests/relations.sx — Phase 4 standard relations.
|
||||
;;
|
||||
;; Includes the classic miniKanren canaries: appendo forwards / backwards /
|
||||
;; bidirectionally, membero, listo enumeration.
|
||||
|
||||
;; --- nullo / pairo ---
|
||||
|
||||
(mk-test
|
||||
"nullo-empty-succeeds"
|
||||
(run* q (nullo (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test "nullo-non-empty-fails" (run* q (nullo (list 1))) (list))
|
||||
|
||||
(mk-test
|
||||
"pairo-non-empty-succeeds"
|
||||
(run* q (pairo (list 1 2)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test "pairo-empty-fails" (run* q (pairo (list))) (list))
|
||||
|
||||
;; --- caro / cdro / firsto / resto ---
|
||||
|
||||
(mk-test
|
||||
"caro-extracts-head"
|
||||
(run* q (caro (list 1 2 3) q))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"cdro-extracts-tail"
|
||||
(run* q (cdro (list 1 2 3) q))
|
||||
(list (list 2 3)))
|
||||
|
||||
(mk-test
|
||||
"firsto-alias-of-caro"
|
||||
(run* q (firsto (list 10 20) q))
|
||||
(list 10))
|
||||
|
||||
(mk-test
|
||||
"resto-alias-of-cdro"
|
||||
(run* q (resto (list 10 20) q))
|
||||
(list (list 20)))
|
||||
|
||||
(mk-test
|
||||
"caro-cdro-build"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(h t)
|
||||
(caro (list 1 2 3) h)
|
||||
(cdro (list 1 2 3) t)
|
||||
(== q (list h t))))
|
||||
(list (list 1 (list 2 3))))
|
||||
|
||||
;; --- conso ---
|
||||
|
||||
(mk-test
|
||||
"conso-forward"
|
||||
(run* q (conso 0 (list 1 2 3) q))
|
||||
(list (list 0 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"conso-extract-head"
|
||||
(run*
|
||||
q
|
||||
(conso
|
||||
q
|
||||
(list 2 3)
|
||||
(list 1 2 3)))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"conso-extract-tail"
|
||||
(run* q (conso 1 q (list 1 2 3)))
|
||||
(list (list 2 3)))
|
||||
|
||||
;; --- listo ---
|
||||
|
||||
(mk-test
|
||||
"listo-empty-succeeds"
|
||||
(run* q (listo (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"listo-finite-list-succeeds"
|
||||
(run* q (listo (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"listo-enumerates-shapes"
|
||||
(run 3 q (listo q))
|
||||
(list
|
||||
(list)
|
||||
(list (make-symbol "_.0"))
|
||||
(list (make-symbol "_.0") (make-symbol "_.1"))))
|
||||
|
||||
;; --- appendo: the canary ---
|
||||
|
||||
(mk-test
|
||||
"appendo-forward-simple"
|
||||
(run*
|
||||
q
|
||||
(appendo (list 1 2) (list 3 4) q))
|
||||
(list (list 1 2 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo-forward-empty-l"
|
||||
(run* q (appendo (list) (list 3 4) q))
|
||||
(list (list 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo-forward-empty-s"
|
||||
(run* q (appendo (list 1 2) (list) q))
|
||||
(list (list 1 2)))
|
||||
|
||||
(mk-test
|
||||
"appendo-recovers-tail"
|
||||
(run*
|
||||
q
|
||||
(appendo
|
||||
(list 1 2)
|
||||
q
|
||||
(list 1 2 3 4)))
|
||||
(list (list 3 4)))
|
||||
|
||||
(mk-test
|
||||
"appendo-recovers-prefix"
|
||||
(run*
|
||||
q
|
||||
(appendo
|
||||
q
|
||||
(list 3 4)
|
||||
(list 1 2 3 4)))
|
||||
(list (list 1 2)))
|
||||
|
||||
(mk-test
|
||||
"appendo-backward-all-splits"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(l s)
|
||||
(appendo l s (list 1 2 3))
|
||||
(== q (list l s))))
|
||||
(list
|
||||
(list (list) (list 1 2 3))
|
||||
(list (list 1) (list 2 3))
|
||||
(list (list 1 2) (list 3))
|
||||
(list (list 1 2 3) (list))))
|
||||
|
||||
(mk-test
|
||||
"appendo-empty-empty-empty"
|
||||
(run* q (appendo (list) (list) q))
|
||||
(list (list)))
|
||||
|
||||
;; --- membero ---
|
||||
|
||||
(mk-test
|
||||
"membero-element-present"
|
||||
(run
|
||||
1
|
||||
q
|
||||
(membero 2 (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"membero-element-absent-empty"
|
||||
(run* q (membero 99 (list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"membero-enumerates"
|
||||
(run* q (membero q (list "a" "b" "c")))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
;; --- reverseo ---
|
||||
|
||||
(mk-test
|
||||
"reverseo-forward"
|
||||
(run* q (reverseo (list 1 2 3) q))
|
||||
(list (list 3 2 1)))
|
||||
|
||||
(mk-test "reverseo-empty" (run* q (reverseo (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"reverseo-singleton"
|
||||
(run* q (reverseo (list 42) q))
|
||||
(list (list 42)))
|
||||
|
||||
(mk-test
|
||||
"reverseo-five"
|
||||
(run*
|
||||
q
|
||||
(reverseo (list 1 2 3 4 5) q))
|
||||
(list (list 5 4 3 2 1)))
|
||||
|
||||
(mk-test
|
||||
"reverseo-backward-one"
|
||||
(run 1 q (reverseo q (list 1 2 3)))
|
||||
(list (list 3 2 1)))
|
||||
|
||||
(mk-test
|
||||
"reverseo-round-trip"
|
||||
(run*
|
||||
q
|
||||
(fresh (mid) (reverseo (list "a" "b" "c") mid) (reverseo mid q)))
|
||||
(list (list "a" "b" "c")))
|
||||
|
||||
;; --- lengtho (Peano-style) ---
|
||||
|
||||
(mk-test "lengtho-empty-is-z" (run* q (lengtho (list) q)) (list :z))
|
||||
|
||||
(mk-test
|
||||
"lengtho-of-3"
|
||||
(run* q (lengtho (list "a" "b" "c") q))
|
||||
(list (list :s (list :s (list :s :z)))))
|
||||
|
||||
(mk-test
|
||||
"lengtho-empty-from-zero"
|
||||
(run 1 q (lengtho q :z))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"lengtho-enumerates-of-length-2"
|
||||
(run 1 q (lengtho q (list :s (list :s :z))))
|
||||
(list (list (make-symbol "_.0") (make-symbol "_.1"))))
|
||||
|
||||
;; --- inserto ---
|
||||
|
||||
(mk-test
|
||||
"inserto-front"
|
||||
(run* q (inserto 0 (list 1 2 3) q))
|
||||
(list
|
||||
(list 0 1 2 3)
|
||||
(list 1 0 2 3)
|
||||
(list 1 2 0 3)
|
||||
(list 1 2 3 0)))
|
||||
|
||||
(mk-test
|
||||
"inserto-empty"
|
||||
(run* q (inserto 0 (list) q))
|
||||
(list (list 0)))
|
||||
|
||||
;; --- permuteo ---
|
||||
|
||||
(mk-test "permuteo-empty" (run* q (permuteo (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"permuteo-singleton"
|
||||
(run* q (permuteo (list 42) q))
|
||||
(list (list 42)))
|
||||
|
||||
(mk-test
|
||||
"permuteo-two"
|
||||
(run* q (permuteo (list 1 2) q))
|
||||
(list (list 1 2) (list 2 1)))
|
||||
|
||||
(mk-test
|
||||
"permuteo-three-as-set"
|
||||
(let
|
||||
((perms (run* q (permuteo (list 1 2 3) q))))
|
||||
(and
|
||||
(= (len perms) 6)
|
||||
(and
|
||||
(some (fn (p) (= p (list 1 2 3))) perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 2 1 3)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 1 3 2)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 2 3 1)))
|
||||
perms)
|
||||
(and
|
||||
(some
|
||||
(fn (p) (= p (list 3 1 2)))
|
||||
perms)
|
||||
(some
|
||||
(fn (p) (= p (list 3 2 1)))
|
||||
perms))))))))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"permuteo-backward-finds-input"
|
||||
(run 1 q (permuteo q (list "a" "b" "c")))
|
||||
(list (list "a" "b" "c")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,39 +0,0 @@
|
||||
;; lib/minikanren/tests/removeo-allo.sx — remove every occurrence of x.
|
||||
|
||||
(mk-test
|
||||
"removeo-allo-multi"
|
||||
(run*
|
||||
q
|
||||
(removeo-allo
|
||||
2
|
||||
(list 1 2 3 2 4 2)
|
||||
q))
|
||||
(list (list 1 3 4)))
|
||||
|
||||
(mk-test
|
||||
"removeo-allo-single"
|
||||
(run*
|
||||
q
|
||||
(removeo-allo 2 (list 1 2 3) q))
|
||||
(list (list 1 3)))
|
||||
|
||||
(mk-test
|
||||
"removeo-allo-no-match"
|
||||
(run*
|
||||
q
|
||||
(removeo-allo 99 (list 1 2 3) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"removeo-allo-everything"
|
||||
(run*
|
||||
q
|
||||
(removeo-allo 1 (list 1 1 1) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"removeo-allo-empty"
|
||||
(run* q (removeo-allo 1 (list) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,69 +0,0 @@
|
||||
;; lib/minikanren/tests/repeato-concato.sx — repeat element n times +
|
||||
;; concatenate a list of lists.
|
||||
|
||||
(define
|
||||
mk-nat
|
||||
(fn (n) (if (= n 0) :z (list :s (mk-nat (- n 1))))))
|
||||
|
||||
;; --- repeato ---
|
||||
|
||||
(mk-test
|
||||
"repeato-zero"
|
||||
(run* q (repeato :a (mk-nat 0) q))
|
||||
(list (list)))
|
||||
(mk-test
|
||||
"repeato-one"
|
||||
(run* q (repeato :a (mk-nat 1) q))
|
||||
(list (list :a)))
|
||||
(mk-test
|
||||
"repeato-three"
|
||||
(run* q (repeato :a (mk-nat 3) q))
|
||||
(list (list :a :a :a)))
|
||||
|
||||
(mk-test
|
||||
"repeato-numeric"
|
||||
(run* q (repeato 7 (mk-nat 4) q))
|
||||
(list (list 7 7 7 7)))
|
||||
|
||||
(mk-test
|
||||
"repeato-recover-count"
|
||||
(run* q (repeato :x q (list :x :x :x :x)))
|
||||
(list (mk-nat 4)))
|
||||
|
||||
;; --- concato ---
|
||||
|
||||
(mk-test "concato-empty" (run* q (concato (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"concato-single"
|
||||
(run* q (concato (list (list 1 2 3)) q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-test
|
||||
"concato-multi"
|
||||
(run*
|
||||
q
|
||||
(concato
|
||||
(list
|
||||
(list 1 2)
|
||||
(list 3)
|
||||
(list 4 5 6))
|
||||
q))
|
||||
(list
|
||||
(list 1 2 3 4 5 6)))
|
||||
|
||||
(mk-test
|
||||
"concato-all-empty"
|
||||
(run* q (concato (list (list) (list) (list)) q))
|
||||
(list (list)))
|
||||
|
||||
(mk-test
|
||||
"concato-mixed-empty"
|
||||
(run*
|
||||
q
|
||||
(concato
|
||||
(list (list 1) (list) (list 2 3))
|
||||
q))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,46 +0,0 @@
|
||||
;; lib/minikanren/tests/rev-acco.sx — accumulator-style reverse.
|
||||
;;
|
||||
;; Faster than reverseo for forward queries (no quadratic appendos).
|
||||
;; Trade-off: rev-acco is asymmetric (acc=initial-empty for the public
|
||||
;; interface), so it does not cleanly run backwards in run* the way
|
||||
;; reverseo does.
|
||||
|
||||
(mk-test "rev-2o-empty" (run* q (rev-2o (list) q)) (list (list)))
|
||||
|
||||
(mk-test
|
||||
"rev-2o-singleton"
|
||||
(run* q (rev-2o (list 7) q))
|
||||
(list (list 7)))
|
||||
|
||||
(mk-test
|
||||
"rev-2o-three"
|
||||
(run* q (rev-2o (list 1 2 3) q))
|
||||
(list (list 3 2 1)))
|
||||
|
||||
(mk-test
|
||||
"rev-2o-five"
|
||||
(run*
|
||||
q
|
||||
(rev-2o (list 1 2 3 4 5) q))
|
||||
(list (list 5 4 3 2 1)))
|
||||
|
||||
(mk-test
|
||||
"rev-2o-strings"
|
||||
(run* q (rev-2o (list "a" "b" "c") q))
|
||||
(list (list "c" "b" "a")))
|
||||
|
||||
(mk-test
|
||||
"rev-2o-reverseo-agree"
|
||||
(let
|
||||
((via-reverseo (first (run* q (reverseo (list 1 2 3 4 5) q))))
|
||||
(via-rev-2o
|
||||
(first
|
||||
(run*
|
||||
q
|
||||
(rev-2o
|
||||
(list 1 2 3 4 5)
|
||||
q)))))
|
||||
(= via-reverseo via-rev-2o))
|
||||
true)
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,114 +0,0 @@
|
||||
;; lib/minikanren/tests/run.sx — Phase 3 tests for run* / run / reify.
|
||||
|
||||
;; --- canonical TRS one-liners ---
|
||||
|
||||
(mk-test "run*-eq-one" (run* q (== q 1)) (list 1))
|
||||
(mk-test "run*-eq-string" (run* q (== q "hello")) (list "hello"))
|
||||
(mk-test "run*-eq-symbol" (run* q (== q (quote sym))) (list (quote sym)))
|
||||
(mk-test "run*-fail-empty" (run* q (== 1 2)) (list))
|
||||
|
||||
;; --- run with a count ---
|
||||
|
||||
(mk-test
|
||||
"run-3-of-many"
|
||||
(run
|
||||
3
|
||||
q
|
||||
(conde
|
||||
((== q 1))
|
||||
((== q 2))
|
||||
((== q 3))
|
||||
((== q 4))
|
||||
((== q 5))))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test "run-zero-empty" (run 0 q (== q 1)) (list))
|
||||
|
||||
(mk-test
|
||||
"run-1-takes-one"
|
||||
(run 1 q (conde ((== q "a")) ((== q "b"))))
|
||||
(list "a"))
|
||||
|
||||
;; --- reification: unbound vars get _.N left-to-right ---
|
||||
|
||||
(mk-test
|
||||
"reify-single-unbound"
|
||||
(run* q (fresh (x) (== q x)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"reify-pair-unbound"
|
||||
(run* q (fresh (x y) (== q (list x y))))
|
||||
(list (list (make-symbol "_.0") (make-symbol "_.1"))))
|
||||
|
||||
(mk-test
|
||||
"reify-mixed-bound-unbound"
|
||||
(run* q (fresh (x y) (== q (list 1 x 2 y))))
|
||||
(list
|
||||
(list 1 (make-symbol "_.0") 2 (make-symbol "_.1"))))
|
||||
|
||||
(mk-test
|
||||
"reify-shared-unbound-same-name"
|
||||
(run* q (fresh (x) (== q (list x x))))
|
||||
(list (list (make-symbol "_.0") (make-symbol "_.0"))))
|
||||
|
||||
(mk-test
|
||||
"reify-distinct-unbound-distinct-names"
|
||||
(run* q (fresh (x y) (== q (list x y x y))))
|
||||
(list
|
||||
(list
|
||||
(make-symbol "_.0")
|
||||
(make-symbol "_.1")
|
||||
(make-symbol "_.0")
|
||||
(make-symbol "_.1"))))
|
||||
|
||||
;; --- conde + run* ---
|
||||
|
||||
(mk-test
|
||||
"run*-conde-three"
|
||||
(run*
|
||||
q
|
||||
(conde ((== q 1)) ((== q 2)) ((== q 3))))
|
||||
(list 1 2 3))
|
||||
|
||||
(mk-test
|
||||
"run*-conde-fresh-mix"
|
||||
(run*
|
||||
q
|
||||
(conde ((fresh (x) (== q (list 1 x)))) ((== q "ground"))))
|
||||
(list (list 1 (make-symbol "_.0")) "ground"))
|
||||
|
||||
;; --- run* + conjunction ---
|
||||
|
||||
(mk-test
|
||||
"run*-conj-binds-q"
|
||||
(run* q (fresh (x) (== x 5) (== q (list x x))))
|
||||
(list (list 5 5)))
|
||||
|
||||
;; --- run* + condu ---
|
||||
|
||||
(mk-test
|
||||
"run*-condu-first-wins"
|
||||
(run* q (condu ((== q 1)) ((== q 2))))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"run*-onceo-trim"
|
||||
(run* q (onceo (conde ((== q "a")) ((== q "b")))))
|
||||
(list "a"))
|
||||
|
||||
;; --- multi-goal run ---
|
||||
|
||||
(mk-test
|
||||
"run*-three-goals"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x y z)
|
||||
(== x 1)
|
||||
(== y 2)
|
||||
(== z 3)
|
||||
(== q (list x y z))))
|
||||
(list (list 1 2 3)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,46 +0,0 @@
|
||||
;; lib/minikanren/tests/selecto.sx — choose an element + rest of list.
|
||||
|
||||
(mk-test
|
||||
"selecto-enumerate"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(x r)
|
||||
(selecto x r (list 1 2 3))
|
||||
(== q (list x r))))
|
||||
(list
|
||||
(list 1 (list 2 3))
|
||||
(list 2 (list 1 3))
|
||||
(list 3 (list 1 2))))
|
||||
|
||||
(mk-test
|
||||
"selecto-find-rest"
|
||||
(run* q (selecto 2 q (list 1 2 3)))
|
||||
(list (list 1 3)))
|
||||
|
||||
(mk-test
|
||||
"selecto-find-element"
|
||||
(run*
|
||||
q
|
||||
(selecto
|
||||
q
|
||||
(list 1 3)
|
||||
(list 1 2 3)))
|
||||
(list 2))
|
||||
|
||||
(mk-test
|
||||
"selecto-element-not-present-fails"
|
||||
(run* q (selecto 99 q (list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"selecto-empty-list-fails"
|
||||
(run* q (selecto q (list) (list)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"selecto-singleton"
|
||||
(run* q (fresh (x r) (selecto x r (list :only)) (== q (list x r))))
|
||||
(list (list :only (list))))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,47 +0,0 @@
|
||||
;; lib/minikanren/tests/simplifyo.sx — algebraic expression simplifier
|
||||
;; demo using conda for first-match-wins dispatch.
|
||||
|
||||
(define
|
||||
simplify-step-o
|
||||
(fn
|
||||
(expr result)
|
||||
(conda
|
||||
((fresh (x) (== expr (list :+ 0 x)) (== result x)))
|
||||
((fresh (x) (== expr (list :+ x 0)) (== result x)))
|
||||
((fresh (y) (== expr (list :* 0 y)) (== result 0)))
|
||||
((fresh (x) (== expr (list :* x 0)) (== result 0)))
|
||||
((fresh (x) (== expr (list :* 1 x)) (== result x)))
|
||||
((fresh (x) (== expr (list :* x 1)) (== result x)))
|
||||
((== result expr))))) ;; default: unchanged
|
||||
|
||||
(mk-test
|
||||
"simplify-zero-plus"
|
||||
(run* q (simplify-step-o (list :+ 0 :y) q))
|
||||
(list :y))
|
||||
|
||||
(mk-test
|
||||
"simplify-plus-zero"
|
||||
(run* q (simplify-step-o (list :+ :x 0) q))
|
||||
(list :x))
|
||||
|
||||
(mk-test
|
||||
"simplify-zero-times"
|
||||
(run* q (simplify-step-o (list :* 0 :y) q))
|
||||
(list 0))
|
||||
|
||||
(mk-test
|
||||
"simplify-one-times"
|
||||
(run* q (simplify-step-o (list :* 1 :y) q))
|
||||
(list :y))
|
||||
|
||||
(mk-test
|
||||
"simplify-no-rule-applies"
|
||||
(run* q (simplify-step-o (list :+ :x :y) q))
|
||||
(list (list :+ :x :y)))
|
||||
|
||||
(mk-test
|
||||
"simplify-non-identity-form"
|
||||
(run* q (simplify-step-o (list :+ 5 7) q))
|
||||
(list (list :+ 5 7)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,40 +0,0 @@
|
||||
;; lib/minikanren/tests/sortedo.sx — checks list is non-decreasing.
|
||||
|
||||
(mk-test
|
||||
"sortedo-empty"
|
||||
(run* q (sortedo (list)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"sortedo-singleton"
|
||||
(run* q (sortedo (list 42)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"sortedo-ascending"
|
||||
(run* q (sortedo (list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"sortedo-with-equal-adjacent"
|
||||
(run*
|
||||
q
|
||||
(sortedo (list 1 1 2 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"sortedo-out-of-order-fails"
|
||||
(run* q (sortedo (list 1 3 2)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"sortedo-descending-fails"
|
||||
(run* q (sortedo (list 3 2 1)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"sortedo-pair-equal"
|
||||
(run* q (sortedo (list 5 5)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,60 +0,0 @@
|
||||
;; lib/minikanren/tests/subo.sx — contiguous-sublist relation.
|
||||
|
||||
(mk-test
|
||||
"subo-simple-found"
|
||||
(run*
|
||||
q
|
||||
(subo
|
||||
(list 2 3)
|
||||
(list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subo-not-contiguous-fails"
|
||||
(run*
|
||||
q
|
||||
(subo
|
||||
(list 2 4)
|
||||
(list 1 2 3 4)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"subo-full-list-found"
|
||||
(run*
|
||||
q
|
||||
(subo
|
||||
(list 1 2 3)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subo-empty-list-found"
|
||||
(let
|
||||
((res (run* q (subo (list) (list 1 2 3)))))
|
||||
(= (len res) 4))
|
||||
true)
|
||||
|
||||
(mk-test
|
||||
"subo-prefix"
|
||||
(run*
|
||||
q
|
||||
(subo
|
||||
(list 1 2)
|
||||
(list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subo-suffix"
|
||||
(run*
|
||||
q
|
||||
(subo
|
||||
(list 3 4)
|
||||
(list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subo-strings"
|
||||
(run* q (subo (list "b" "c") (list "a" "b" "c" "d")))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,62 +0,0 @@
|
||||
;; lib/minikanren/tests/subseto.sx — every element of l1 is in l2.
|
||||
|
||||
(mk-test
|
||||
"subseto-empty"
|
||||
(run* q (subseto (list) (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subseto-singleton-yes"
|
||||
(run*
|
||||
q
|
||||
(subseto (list 2) (list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subseto-singleton-no"
|
||||
(run*
|
||||
q
|
||||
(subseto (list 99) (list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"subseto-multi-yes"
|
||||
(run
|
||||
1
|
||||
q
|
||||
(subseto
|
||||
(list 1 3)
|
||||
(list 1 2 3 4)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-test
|
||||
"subseto-multi-no"
|
||||
(run*
|
||||
q
|
||||
(subseto
|
||||
(list 1 99)
|
||||
(list 1 2 3)))
|
||||
(list))
|
||||
|
||||
(mk-test
|
||||
"subseto-equal-sets"
|
||||
(run
|
||||
1
|
||||
q
|
||||
(subseto
|
||||
(list 1 2 3)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
;; allow duplicates in l1 — each just needs membership in l2.
|
||||
(mk-test
|
||||
"subseto-duplicates-allowed"
|
||||
(run
|
||||
1
|
||||
q
|
||||
(subseto
|
||||
(list 1 1 2)
|
||||
(list 1 2 3)))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,44 +0,0 @@
|
||||
;; lib/minikanren/tests/sum-product.sx — fold list to integer.
|
||||
|
||||
(mk-test "sumo-empty" (run* q (sumo (list) q)) (list 0))
|
||||
(mk-test
|
||||
"sumo-1-to-5"
|
||||
(run*
|
||||
q
|
||||
(sumo (list 1 2 3 4 5) q))
|
||||
(list 15))
|
||||
(mk-test
|
||||
"sumo-zeros"
|
||||
(run* q (sumo (list 0 0 0) q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"sumo-negs"
|
||||
(run* q (sumo (list 5 -3 8) q))
|
||||
(list 10))
|
||||
|
||||
(mk-test "producto-empty" (run* q (producto (list) q)) (list 1))
|
||||
(mk-test
|
||||
"producto-1-to-4"
|
||||
(run* q (producto (list 1 2 3 4) q))
|
||||
(list 24))
|
||||
(mk-test
|
||||
"producto-with-0"
|
||||
(run* q (producto (list 5 0 7) q))
|
||||
(list 0))
|
||||
(mk-test
|
||||
"producto-of-1s"
|
||||
(run* q (producto (list 1 1 1) q))
|
||||
(list 1))
|
||||
|
||||
(mk-test
|
||||
"sum-product-pythagorean-square"
|
||||
(run*
|
||||
q
|
||||
(fresh
|
||||
(s sq2)
|
||||
(sumo (list 3 4 5) s)
|
||||
(producto (list 3 3) sq2)
|
||||
(== q (list s sq2))))
|
||||
(list (list 12 9)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,32 +0,0 @@
|
||||
;; lib/minikanren/tests/swap-firsto.sx — swap first two elements.
|
||||
|
||||
(mk-test
|
||||
"swap-firsto-pair"
|
||||
(run* q (swap-firsto (list 1 2) q))
|
||||
(list (list 2 1)))
|
||||
|
||||
(mk-test
|
||||
"swap-firsto-with-tail"
|
||||
(run* q (swap-firsto (list 1 2 3 4) q))
|
||||
(list (list 2 1 3 4)))
|
||||
|
||||
(mk-test
|
||||
"swap-firsto-singleton-fails"
|
||||
(run* q (swap-firsto (list 1) q))
|
||||
(list))
|
||||
|
||||
(mk-test "swap-firsto-empty-fails" (run* q (swap-firsto (list) q)) (list))
|
||||
|
||||
(mk-test
|
||||
"swap-firsto-self-inverse"
|
||||
(run*
|
||||
q
|
||||
(fresh (mid) (swap-firsto (list :a :b :c :d) mid) (swap-firsto mid q)))
|
||||
(list (list :a :b :c :d)))
|
||||
|
||||
(mk-test
|
||||
"swap-firsto-backward"
|
||||
(run* q (swap-firsto q (list :y :x :z)))
|
||||
(list (list :x :y :z)))
|
||||
|
||||
(mk-tests-run!)
|
||||
@@ -1,55 +0,0 @@
|
||||
;; lib/minikanren/tests/tabling-more.sx — table-1 + table-3.
|
||||
|
||||
;; --- table-1 (predicate caching) ---
|
||||
|
||||
(define
|
||||
tab-in-list
|
||||
(table-1
|
||||
"in-list"
|
||||
(fn
|
||||
(x)
|
||||
(membero
|
||||
x
|
||||
(list 1 2 3 4 5)))))
|
||||
|
||||
(mk-tab-clear!)
|
||||
(mk-test
|
||||
"table-1-hit"
|
||||
(run* q (tab-in-list 3))
|
||||
(list (make-symbol "_.0")))
|
||||
(mk-test "table-1-miss-no" (run* q (tab-in-list 99)) (list))
|
||||
(mk-test
|
||||
"table-1-replay"
|
||||
(run* q (tab-in-list 3))
|
||||
(list (make-symbol "_.0")))
|
||||
|
||||
;; --- table-3 (Ackermann) ---
|
||||
|
||||
(define
|
||||
ack-o
|
||||
(table-3
|
||||
"ack"
|
||||
(fn
|
||||
(m n result)
|
||||
(conde
|
||||
((== m 0) (pluso-i n 1 result))
|
||||
((fresh (m-1) (lto-i 0 m) (== n 0) (minuso-i m 1 m-1) (ack-o m-1 1 result)))
|
||||
((fresh (m-1 n-1 inner) (lto-i 0 m) (lto-i 0 n) (minuso-i m 1 m-1) (minuso-i n 1 n-1) (ack-o m n-1 inner) (ack-o m-1 inner result)))))))
|
||||
|
||||
(mk-tab-clear!)
|
||||
(mk-test
|
||||
"ack-0-0"
|
||||
(run* q (ack-o 0 0 q))
|
||||
(list 1))
|
||||
(mk-tab-clear!)
|
||||
(mk-test
|
||||
"ack-2-3"
|
||||
(run* q (ack-o 2 3 q))
|
||||
(list 9))
|
||||
(mk-tab-clear!)
|
||||
(mk-test
|
||||
"ack-3-3"
|
||||
(run* q (ack-o 3 3 q))
|
||||
(list 61))
|
||||
|
||||
(mk-tests-run!)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user