Programming challenges

Question

This thread serves as a collection of small (solvable in less than 1 hour), but yet not trivial programming challenges. Please feel free to post your solution below, but try to avoid lengthy discussions.
1. Challenge:
Create a program to print the solution for any given (solvable, i.e. no guessing is needed) sudoku puzzle. Puzzles are represented as follows:
5 3 0 0 7 0 0 0 0
6 0 0 1 9 5 0 0 0
0 9 8 0 0 0 0 6 0
8 0 0 0 6 0 0 0 3
4 0 0 8 0 3 0 0 1
7 0 0 0 2 0 0 0 6
0 6 0 0 0 0 2 8 0
0 0 0 4 1 9 0 0 5
0 0 0 0 8 0 0 7 9
2. Challenge:
Create a program which takes a conjugated (regular) verb from in the present tense in various languages and tells you the language and the infinitive of the verb.
For simplicity's sake, I'll narrow it down a bit further: The program should be able to recognize German regular verbs (see "spielen"), Portuguese verbs on -ar (see "falar") and French verbs on -ir (see "choisir")
Example session:
$ ./lang kennst
German: kennen
./lang cantam
Portuguese: cantar
./lang finit
French: finir
If you want to suggest another challenge, please write me a mail. Remarkable solutions (very fast, small or elegant) for each challenge will be highlighted.
Last edited by wuischke (2008-03-02 13:12:33)

Answer 1

wuischke wrote:
OK, I'll post my solution as well. Written in ansi-C. It's sometimes very ugly (particularly the code to clear the square), well, but it works. You can add a call to the "PrintField" function before adding each value to see how this solver works.
I've seen incredibly small solvers written in Haskell - anyone here who knows functional programming languages well enough to post a nice solution?
This is a late solution to the first one.
This haskell solver isn't too small, but it is fast, and does guess when it gets stuck.
I used a similar strategy to yours: fill a list of lists with lists of candidates, and repeatedly check rows, columns, 3x3 squares (with wheel), and eliminate taken numbers (which also including 1 if we already have [1,2] in two spots).
It's a bit long, but it does guess once the above strategy stops changing the square, which solves all the newspaper problems I've tried (some of which end up taking the algorithm to maybe 15 dead ends: without guessing, those could probably be solved more intelligently using linear algebra (the problem is still np) (since each row,col,3x3 totals 45, giving at least as many equations as knowns), which would be elegant, but probably less efficient and more confusing)
My parser takes files without spaces, since I like it that way.
Ex:
53__7____
6__195___
_98____6_
8___6___3
4__8_3__1
7___2___6
_6____28_
___419__5
____8__79
Here it is:
module Main where
import Control.Monad
import Data.Maybe
import Data.Char (digitToInt,intToDigit)
import Data.List (nub,transpose,group,sort)
import Debug.Trace
import System.Environment
type MagicSq = [[[Int]]]
main = do f <- getArgs
if null f then error "specify one or more sudoku problem files to solve"
else mapM (\x -> unparseSq . solPret . rowsPar =<< readFile x) f
sol :: (Monad m) => [MagicSq] -> m [MagicSq]
sol = liftM (concat) . mapM sol'
sol' :: (Monad m) => MagicSq -> m [MagicSq]
sol' = let y x = mapMaybe wheel $ x
ty x = let yx = y x in trace ("branch of: " ++ show (length yx)) yx
in return . y . branch
solPret x = let f x = untillSame $ scanl (>>=) (sol x) $ repeat sol
-- somewhere magicSq is reversed... corrected here
goodSol x = if length x == 1 then return $ reverse $ head x
else fail "multiple, possibly incomplete solution found"
in join $ goodSol =<< f (wheel' x)
branch :: MagicSq -> [MagicSq]
branch x = if isSolved x then [x]
else map (unConcat x) $ branchRow $ concat x
where
unConcat o = segment $ length o
branchRow = bR []
bR a [] = []
bR a (l:ls)
| length l == min = map (\split -> (reverse a) ++ [split]:ls) l
| otherwise = bR (l:a) ls
where min = minimum $ filter (1/=) $ map length (l:ls)
wheel x = untillSame $ scanl (>>=) (wheel' x) $ repeat wheel'
wheel' x = rowCk x >>= zoneApp rowCk >>= colCk
untillSame (l:m:ms) = if l == m then l else untillSame (m:ms)
rowCk,colCk :: (Ord a, Show a, Monad m) => [[[a]]] -> m [[[a]]]
rowCk x = let exclCks x = foldr (=<<) (return x) $ map (exclusionCk) [1..2]
y = map (exclCks) x
--y = map (totalOneCk) x
in if Nothing `elem` y then fail "A row failed"
else return (map fromJust $ y)
colCk = liftM transpose . rowCk . transpose
zoneApp f = liftM (zC 3) . f . zC 3
zC _ [] = []
zC _ [[[]]] = [[[]]]
zC z l = let (i,ls) = splitAt z l
nrs = map (segment z) i
headGr x | null $ concat $ concat x = []
| otherwise = concatMap (head) x : headGr (map tail x)
in if length l `mod` z == 0
then headGr nrs ++ (zC z ls)
else error $ "square edge length:" ++ show (length l)
++ "does not divide by: " ++ show z
segment n l = let (a,as) = splitAt n l
in if null as then [a] else a:segment n as
rowsPar = parseSq . par' [] []
where
par' a b [] = (a)
par' a b ('\n':xs) = par' (reverse b :a) [] xs
par' a b (x:xs) = par' a (x:b) xs
parseSq :: [String] -> MagicSq
parseSq p@(m:ms) = if length m /= length p
then error "Must use a square grid"
else map (\x -> map (options) x) p
where
options x | x `elem` ['1'..intToDigit (length m)] = [digitToInt x]
| otherwise = [1..length m ]
unparseSq x = if isSolved x
then putStrLn $ unlines $ map show $ map (concatMap (map intToDigit)) x
else putStrLn $ unlines $ map show $ map (map (map intToDigit)) x
isSolved x = (length x)^2 == (length $ concat $ concat x)
totalOneCk l = let decided = concat $ filter (\x -> 1 == length x) l
uniqueL x = length x == length (nub x)
f x = if length x == 1 then x
else filter (\x -> x `notElem` decided) x
in if uniqueL decided then return $ map (f) l
else fail $ "Invalid row: " ++ show decided
-- this is a generalization of the totalOneCk; candidates are eliminated
-- based on the values in n same candidate lists of n length
exclusionCk :: (Monad m, Ord a, Show a) => Int -> [[a]] -> m [[a]]
exclusionCk n l =
let areLen = filter (\x -> n == length x)
ggs = group $ sort $ areLen l
ugPairs = areLen ggs
removals = map (head) ugPairs
maxGG = maximum $ map length $ ggs
errPP = fail $ "Length " ++ show n
++ " overbooked: " ++ show ggs
++ "\nIn: " ++ show l
-- The actual filter
f l [] = l
f l (r:rs)
| length l == 1 = l
| l == r = l
| otherwise = f (filter (\x -> x `notElem` r) l) rs
manage | null ugPairs = return l
| maxGG > n = errPP
| otherwise = return $ map (\l -> f l removals) l
in manage
edit: changed branch (guessing) to take the first smallest branch.
Last edited by vogt (2008-08-08 00:56:00)