diff --git a/colorize-map.p6 b/colorize-map.p6 index 1bd53de..b35e507 100644 --- a/colorize-map.p6 +++ b/colorize-map.p6 @@ -21,9 +21,7 @@ my @states = < sergipe tocantins >; -for @states -> $state { - $problem.add-variable: $state, @colors; -} +$problem.create-variable: @states, @colors; $problem.unique-vars: ; $problem.unique-vars: ; diff --git a/decript.p6 b/decript.p6 new file mode 100644 index 0000000..8347345 --- /dev/null +++ b/decript.p6 @@ -0,0 +1,11 @@ +use ProblemSolver; +my ProblemSolver $problem .= new; + +$problem.create-variable: , ^100; + +$problem.add-constraint: , -> $_ {. * 3 == . + 14}; +$problem.add-constraint: , -> $_ {. * 2 == .}; +$problem.add-heuristic: , -> $_ {. < .} + +#$problem.print-found = &say; +say $problem.solve.head diff --git a/lib/ProblemSolver.pm6 b/lib/ProblemSolver.pm6 index 4a6d657..7068954 100644 --- a/lib/ProblemSolver.pm6 +++ b/lib/ProblemSolver.pm6 @@ -1,118 +1,159 @@ -use ProblemSolver::State; unit class ProblemSolver; -has Bool $.stop-on-first-solution = False; -has Bool $!found-solution = False; -has Array of Callable %!constraints{Signature}; -has $!variables handles = ProblemSolver::State.new; -#has ProblemSolver::State $!variables handles .= new; -has &.print-found is rw; -has Array of Callable %!heuristics; +has %.variables; +has %.constants; +has Bag $.vars .= new; +has %.constraints{Set}; +has %.heuristics{Set}; +has &.print-found is rw; +has Set %.unordered; -method add-constraint(&const) { - %!constraints{&const.signature}.push: &const +multi method create-variable(Str $name where { not %!variables{$_}:exists }, Bag() \values) { + $!vars = |$!vars ⊎ Pair.new: $name, 1; + %!variables = |%!variables, $name => values; } -method add-heuristic($var, &heu) { - %!heuristics{$var}.push: &heu +multi method create-variable(Bag() $names where { %!variables{$_.none}:exists }, Bag() \values) { + $!vars = $!vars ⊎ $names; + %!variables = |%!variables, |do for $names.keys -> $name { $name => values } } -method solve { - for $!variables.found-vars -> $key { - self!remove-values($!variables, :variable($key), :value($!variables.get($key))) if %!heuristics{$key}:exists; - } - self!solve-all($!variables) +method add-constraint(Set() \vars where {%!variables{.keys.all}:exists}, &constraint) { + %!constraints{vars}.push: &constraint } -method !solve-all($todo) { - do if $todo.found-everything { - my %tmp = $todo.found-hash; - do if self!run-constraints(%tmp, :debug) { - $!found-solution = True; - %tmp - } - } else { - my @resp; - my $key = $todo.next-var; - for $todo.iterate-over($key) -> $new { - next unless self!run-constraints($new.found-hash) or $new.has-empty-vars; - self!remove-values($new, :variable($key), :value($new.get($key))) if %!heuristics{$key}:exists; - &!print-found($new.found-hash) if &!print-found; - @resp.push: self!solve-all($new); - last if $!stop-on-first-solution and $!found-solution - } - |@resp - } +method add-heuristic(Set() \consts where {%!variables{.keys.all}:exists}, &heuristic) { + %!heuristics{consts}.push: &heuristic; } -method !remove-values($todo, Str :$variable, :$value) { - if %!heuristics{$variable}:exists { - for @( %!heuristics{$variable} ) -> &func { - func($todo, $value) - } +proto method remove-possibility($name, $value) { + #note "remove-possibility($name, $value)"; + {*} +} + +multi method remove-possibility(Str \name where {%!variables{name}:exists}, Set() \value) { + for value.keys -> \v { + nextwith(name, v) } } -method !run-constraints(%values, :$debug) { - my @cons = self!get-constraints-for-vars(%values); - for @cons -> &func { - return False if not func(|%values) +multi method remove-possibility(Set \name where {%!variables{.keys.all}:exists}, Set() \value) { + for name.keys -> \n { + nextwith(n, value) } - True } -method !get-constraints-for-vars(%vars) { - my @keys = %!constraints.keys.grep: -> \sig { %vars ~~ sig } - |%!constraints{@keys}.map: |* +multi method remove-possibility(Str $name where {%!variables{$name}:exists}, \value) { + %!variables{$name} = %!variables{$name} ∖ bag(value xx %!variables{$name}{value}); + die "No options" if %!variables{$name}.elems == 0; + if %!variables{$name}.elems == 1 { + %!variables = %!variables.pairs.grep: *.key !~~ $name; + %!constants = |%!constants, $name => value + } } -method constraint-vars(&red, @vars) { - my $pars = &red.signature.params.elems; - my @comb = @vars.combinations($pars); - for @comb -> @pars { - my $sig = @pars.map({":\${$_}!"}).join(", "); - my $cal = @pars.map({"\${$_}"}).join(", "); - use MONKEY-SEE-NO-EVAL; - my &func = EVAL "-> $sig, | \{ red($cal)\}"; - no MONKEY-SEE-NO-EVAL; - $.add-constraint(&func) +method variable-bag { + %!variables.keys + .map(-> Str \var { + my Int $in-constraints = %!constraints.pairs.grep(var ∈ *.key).map(*.value.elems).sum; + my Int $in-heuristics = %!heuristics.pairs.grep(var ∈ *.key).map(*.value.elems).sum; + slip var xx ($!vars{var} * ($in-constraints + 1) * ($in-heuristics + 1)) + }) + .Bag +} + +method get-constraints { + |%!constraints.pairs.grep(*.key ⊆ %!constants.keys.Set).map: |*.value +} + +method classify-heuristics { + %!heuristics.pairs.classify: {%!constants{one(.key)}:!exists ?? .key !! Empty}, :as{.value} +} + +method unique-value-vars(Set() \vars) { + for vars.keys.combinations: 2 -> @vars { + #say @vars; + $.add-constraint(@vars, -> %vars { %vars{@vars[0]} !~~ %vars{@vars[1]} }); + $.add-heuristic( @vars, -> %vars { %vars{@vars[0]} !~~ %vars{@vars[1]} }) } - for @vars -> $var { - my @v = @vars.grep(* !eq $var); - $.add-heuristic($var, -> $todo, $value { - for @v (&) $todo.not-found-vars -> $var { - $todo.find-and-remove-from: $var.key, -> $v { not red($v, $value) } - } - }) +} + +method constraint-vars(Set() \vars, &constraint) { + for vars.keys.combinations: 2 -> @vars { + $.add-constraint(@vars, -> %vars { constraint |%vars{|@vars} }); + $.add-heuristic( @vars, -> %vars { constraint |%vars{|@vars} }) } } -method unique-vars(@vars) { - my @comb = @vars.combinations(2); - for @comb -> @pars { - my $sig = @pars.map({":\${$_}!"}).join(", "); - my $cal = @pars.map({"\${$_}"}).join(", "); - use MONKEY-SEE-NO-EVAL; - my &func = EVAL "-> $sig, | \{ [!~~] $cal \}"; - no MONKEY-SEE-NO-EVAL; - $.add-constraint(&func) +method unordered-vars(Set() \vars) { + for vars.keys -> Str $key { + %!unordered{$key} = vars ∖ set($key); } - for @vars -> $var { - my @v = @vars.grep(* !eq $var); - $.add-heuristic($var, -> $todo, $value { - for @v (&) $todo.not-found-vars -> $var { - $todo.remove-from: $var.key, $value +} + +method run-heuristcs { + # TODO: implement heuristics + my %not-used{Set}; + for |%!heuristics.kv -> %sig, @heu { + my \c = %sig.keys.classify: {%!constants{$_}:exists ?? "const" !! "var"} + if c.elems == 1 { + my %consts = %!constants{|c}:kv; + my $var-name = c.head; + my &gfunc = -> $value { + my %vars = |%consts, $var-name => $value; + ![&&] do for @heu { .(%vars) } } - }) + my %to-remove := set %!variables{$var-name}.keys.grep: &gfunc; + $.remove-possibility($var-name, %to-remove) + } else { + %not-used{%sig} = @heu + } } + %not-used } -method no-order-vars(+@vars) { - for @vars -> $var { - my @v = @vars.grep(* !eq $var); - $.add-heuristic($var, -> $todo, $value { - $todo.recursive-remove-from-vars: @v, $value - }) - } +method next-variable { + $.variable-bag.pairs.max({.value}).key +} + +method solve { + lazy gather $.run-tests; +} + +sub merge-used(%a1, %a2) { + (|%a1.keys, |%a2.keys).unique.map(-> Str $key { + $key => (%a1{$key} // {}) ∪ (%a2{$key} // {}) + }).Map } +sub test-unordered(%un, %test, $var, $value) { + %un{$var}:exists and %test{%un{$var}.any}:exists and %test{%un{$var}.any}{$value} +} + +method run-tests { + my Set %tested = %!constants.kv.map: -> $key, $value {$key => set($value)}; + for $.get-constraints -> &constraint { + return %tested unless constraint(%!constants) + } + .(%!constants) with &!print-found; + if %.variable-bag.elems { + my Str $var = $.next-variable; + my %heuristics := $.run-heuristcs; + for |%!variables{$var}.pairs.sort(-*.value).map: *.key -> $value { + if test-unordered %!unordered, %tested, $var, $value { + next + } + my %constants = |%!constants, $var => $value; + my %variables = |%!variables.pairs.grep: *.key !~~ $var; + my $clone = self.clone: :%variables, :%constants, :%heuristics, :vars($!vars ∖ bag($var xx $!vars{$var})); + my %returned = $clone.run-tests; + %tested = merge-used %tested, %returned; + + #note %tested; + $.remove-possibility($_, %tested{|%!unordered{$_}}) for %!unordered.grep: {%tested{$_}:exists} + } + } else { + take %!constants; + } + %tested +} diff --git a/n-queens.p6 b/n-queens.p6 index 8a87508..628ae3c 100644 --- a/n-queens.p6 +++ b/n-queens.p6 @@ -9,6 +9,7 @@ class Point { "{self.^name}(:x($!x), :y($!y))" } method gist {$.WHICH} + method Bool {$!x and $!y} } sub MAIN(Int $n = 4) { @@ -41,24 +42,25 @@ sub MAIN(Int $n = 4) { my @board = (^$n X ^$n).map(-> ($x, $y) {Point.new: :$x, :$y}); my @vars = (1 .. $n).map: {"Q$_"}; - for @vars -> $var { - $problem.add-variable: $var, @board; - } + $problem.create-variable: @vars, @board; #$problem.no-order-vars: @vars; - $problem.unique-vars: @vars; + $problem.unique-value-vars: @vars; - $problem.constraint-vars: -> $q1, $q2 { + $problem.constraint-vars: @vars, -> $q1, $q2 { $q1.x != $q2.x && $q1.y != $q2.y && $q1.x - $q1.y != $q2.x - $q2.y && $q1.x + $q1.y != $q2.x + $q2.y - }, @vars; + }; - my @response = $problem.solve; - say "\n", "=" x 30, " Answers ", "=" x 30, "\n"; + $problem.unordered-vars: @vars; - for @response -> %ans { + my @solutions = eager $problem.solve; + say "\n", "=" x 30, " Answers ", "=" x 30, "\n"; + for @solutions -> %ans { print-board(%ans) } + + #print-board($problem.solve.head) }