flite-0.1: examples/Sudoku.hs

{

del x Nil = Nil;
del x (Cons y ys) =
  case (==) x y of { True -> ys ; False -> Cons y (del x ys) };

diff xs Nil = xs;
diff xs (Cons y ys) = diff (del y xs) ys;

head (Cons x xs) = x;
tail (Cons x xs) = xs;

length Nil = 0;
length (Cons x xs) = (+) 1 (length xs);

sum Nil = 0;
sum (Cons x xs) = (+) x (sum xs);

null Nil = True;
null (Cons x xs) = False;

single Nil = False;
single (Cons x xs) = null xs;

minimum (Cons x xs) = min x xs;

min m Nil = m;
min m (Cons x xs) = case (<=) x m of { True -> min x xs ; False -> min m xs };

break p Nil = Pair Nil Nil;
break p (Cons x xs) =
  case p x of {
    True -> Pair Nil (Cons x xs);
    False -> case break p xs of { Pair ys zs -> Pair (Cons x ys) zs };
  };

filter p Nil = Nil;
filter p (Cons x xs) =
  case p x of {
    True -> Cons x (filter p xs);
    False -> filter p xs;
  };

zipWith f Nil ys = Nil;
zipWith f (Cons x xs) Nil = Nil;
zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys);

notElem x Nil = True;
notElem x (Cons y ys) = and ((/=) x y) (notElem x ys);

and False x = False;
and True x = x;

not False = True;
not True = False;

or False x = x;
or True x = True;

any p Nil = False;
any p (Cons x xs) = or (p x) (any p xs);

all p Nil = True;
all p (Cons x xs) = and (p x) (all p xs);

map f Nil = Nil;
map f (Cons x xs) = Cons (f x) (map f xs);

append Nil ys = ys;
append (Cons x xs) ys = Cons x (append xs ys);

concat Nil = Nil;
concat (Cons xs xss) = append xs (concat xss);

concatMap f Nil = Nil;
concatMap f (Cons x xs) = append (f x) (concatMap f xs);

take n Nil = Nil;
take n (Cons x xs) =
  case (==) n 0 of {
    True -> Nil;
    False -> Cons x (take ((-) n 1) xs);
  };

drop n Nil = Nil;
drop n (Cons x xs) =
  case (==) n 0 of {
    True -> Cons x xs;
    False -> drop ((-) n 1) xs;
  };

groupBy n xs =
  case null xs of {
    True -> Nil;
    False -> Cons (take n xs) (groupBy n (drop n xs));
  };

id x = x;

comp f g x = f (g x);

boardsize = 9;
boxsize   = 3;
cellvals  = Cons 1 (Cons 2 (Cons 3 (
            Cons 4 (Cons 5 (Cons 6 (
            Cons 7 (Cons 8 (Cons 9 Nil))))))));

blank x = (==) x 0;

nodups Nil = True;
nodups (Cons x xs) = and (notElem x xs) (nodups xs);

singleton x = Cons x Nil;

cols (Cons xs Nil) = map singleton xs;
cols (Cons xs (Cons ys yss)) = zipWith Cons xs (cols (Cons ys yss));

boxs m = map concat (concatMap cols (groupBy 3 (map (groupBy 3) m)));

choices b = map (map choose) b;

choose e = case blank e of { True -> cellvals ; False -> Cons e Nil };

fixed css = concat (filter single css);

reduce css = map (remove (fixed css)) css;

remove fs cs = case single cs of { True -> cs ; False -> diff cs fs };

prune m = pruneBy boxs (pruneBy cols (pruneBy id m));

pruneBy f m = f (map reduce (f m));

blocked cm = or (void cm) (not (safe cm));

void m = any (any null) m;

safe cm = and (all (comp nodups fixed) cm)
              (and (all (comp nodups fixed) (cols cm))
                   (all (comp nodups fixed) (boxs cm)));

best n cs = (==) (length cs) n;

expand cm =
  let { n = minchoice cm } in
    case break (any (best n)) cm of {
      Pair rows1 rows2 ->
        case break (best n) (head rows2) of {
          Pair row1 row2 -> map (exp row1 row2 rows1 rows2) (head row2);
        };
    };

exp row1 row2 rows1 rows2 c =
  append rows1 (append (Cons (append row1 (Cons (Cons c Nil)
                             (tail row2))) Nil)
                       (tail rows2));

minchoice m = minimum (filter gte2 (concatMap (map length) m));

gte2 x = (<=) 2 x;

search cm =
  case blocked cm of {
    True -> Nil;
    False -> case all (all single) cm of {
               True -> Cons cm Nil;
               False -> concatMap (comp search prune) (expand cm);
             };
  };

sudoku b = map (map (map head)) (search (prune (choices b)));

emitRow Nil k = emit '\n' k;
emitRow (Cons x xs) k = emitInt x (emit ' ' (emitRow xs k));

emitMatrix Nil k = k;
emitMatrix (Cons x xs) k = emitRow x (emitMatrix xs k);

main = emitMatrix (head (
       sudoku (Cons (Cons 0 (Cons 0 (Cons 0
                    (Cons 0 (Cons 0 (Cons 3
                    (Cons 0 (Cons 6 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 0 (Cons 0
                    (Cons 0 (Cons 0 (Cons 0
                    (Cons 0 (Cons 1 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 9 (Cons 7
                    (Cons 5 (Cons 0 (Cons 0
                    (Cons 0 (Cons 8 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 0 (Cons 0
                    (Cons 0 (Cons 9 (Cons 0
                    (Cons 2 (Cons 0 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 0 (Cons 8
                    (Cons 0 (Cons 7 (Cons 0
                    (Cons 4 (Cons 0 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 0 (Cons 3
                    (Cons 0 (Cons 6 (Cons 0
                    (Cons 0 (Cons 0 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 1 (Cons 0
                    (Cons 0 (Cons 0 (Cons 2
                    (Cons 8 (Cons 9 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 4 (Cons 0
                    (Cons 0 (Cons 0 (Cons 0
                    (Cons 0 (Cons 0 (Cons 0 Nil)))))))))
              (Cons (Cons 0 (Cons 5 (Cons 0
                    (Cons 1 (Cons 0 (Cons 0
                    (Cons 0 (Cons 0 (Cons 0 Nil)))))))))
               Nil))))))))))) 0;

}