raetsel-der-woche-welches-streichholz-muss-umgelegt-werden

module Main where

import Data.List as List
import Data.Maybe as Maybe
import Data.Char
import System.IO (readFile)

-- Hölzchen umlegen https://www.spiegel.de/forum/karriere/raetsel-der-woche-welches-streichholz-muss-umgelegt-werden-thread-935117-8.html

data Zeichen = Plus | Minus | Gleich | Z0 | Z1 | Z2 | Z3 | Z4 | Z5 | Z6 | Z7 | Z8 | Z9
  deriving (Eq, Show)

data Position = Position   H   --   0     -
                         H H H -- 1 2 3  |-|  zwei Zeichen für Gleich
                          H H  --  4 5    +   zwei Zeichen für Plus
                         H H H -- 6 7 8  |-|  zwei Zeichen für Gleich
                           H   --   9     -
  deriving (Eq)

data H = Holz | Frei
  deriving (Eq)

instance Show Position where
  show p@(Position h0 h1 h2 h3 h4 h5 h6 h7 h8 h9) =
    if p == plus then "+"
    else if p == minus then "-"
    else if p == gleich then "="
    else if p == leer then " "
    else show (head $ findIndices (\e -> e == p) [z0, z1, z2, z3, z4, z5, z6, z7, z8, z9])

plus   = Position Frei  Frei Frei Frei  Holz Holz  Frei Frei Frei  Frei
minus  = Position Frei  Frei Frei Frei  Holz Frei  Frei Frei Frei  Frei
gleich = Position Frei  Frei Holz Frei  Frei Frei  Frei Holz Frei  Frei
leer   = Position Frei  Frei Frei Frei  Frei Frei  Frei Frei Frei  Frei

z0 = Position Holz  Holz Frei Holz  Frei Frei  Holz Frei Holz  Holz
z1 = Position Frei  Frei Frei Holz  Frei Frei  Frei Frei Holz  Frei
z2 = Position Holz  Frei Frei Holz  Holz Frei  Holz Frei Frei  Holz
z3 = Position Holz  Frei Frei Holz  Holz Frei  Frei Frei Holz  Holz
z4 = Position Frei  Holz Frei Holz  Holz Frei  Frei Frei Holz  Frei
z5 = Position Holz  Holz Frei Frei  Holz Frei  Frei Frei Holz  Holz
z6 = Position Holz  Holz Frei Frei  Holz Frei  Holz Frei Holz  Holz
z7 = Position Holz  Frei Frei Holz  Frei Frei  Frei Frei Holz  Frei
z8 = Position Holz  Holz Frei Holz  Holz Frei  Holz Frei Holz  Holz
z9 = Position Holz  Holz Frei Holz  Holz Frei  Frei Frei Holz  Holz

wegnehmenPosition :: Position -> [Position]
wegnehmenPosition (Position h0 h1 h2 h3 h4 h5 h6 h7 h8 h9) = catMaybes [
    if h0 == Holz then Just (Position Frei h1 h2 h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h1 == Holz then Just (Position h0 Frei h2 h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h2 == Holz then Just (Position h0 h1 Frei h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h3 == Holz then Just (Position h0 h1 h2 Frei h4 h5 h6 h7 h8 h9) else Nothing,
    if h4 == Holz then Just (Position h0 h1 h2 h3 Frei h5 h6 h7 h8 h9) else Nothing,
    if h5 == Holz then Just (Position h0 h1 h2 h3 h4 Frei h6 h7 h8 h9) else Nothing,
    if h6 == Holz then Just (Position h0 h1 h2 h3 h4 h5 Frei h7 h8 h9) else Nothing,
    if h7 == Holz then Just (Position h0 h1 h2 h3 h4 h5 h6 Frei h8 h9) else Nothing,
    if h8 == Holz then Just (Position h0 h1 h2 h3 h4 h5 h6 h7 Frei h9) else Nothing,
    if h9 == Holz then Just (Position h0 h1 h2 h3 h4 h5 h6 h7 h8 Frei) else Nothing]

hinzufuegenPosition :: Position -> [Position]
hinzufuegenPosition (Position h0 h1 h2 h3 h4 h5 h6 h7 h8 h9) = catMaybes [
    if h0 == Frei then Just (Position Holz h1 h2 h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h1 == Frei then Just (Position h0 Holz h2 h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h2 == Frei then Just (Position h0 h1 Holz h3 h4 h5 h6 h7 h8 h9) else Nothing,
    if h3 == Frei then Just (Position h0 h1 h2 Holz h4 h5 h6 h7 h8 h9) else Nothing,
    if h4 == Frei then Just (Position h0 h1 h2 h3 Holz h5 h6 h7 h8 h9) else Nothing,
    if h5 == Frei then Just (Position h0 h1 h2 h3 h4 Holz h6 h7 h8 h9) else Nothing,
    if h6 == Frei then Just (Position h0 h1 h2 h3 h4 h5 Holz h7 h8 h9) else Nothing,
    if h7 == Frei then Just (Position h0 h1 h2 h3 h4 h5 h6 Holz h8 h9) else Nothing,
    if h8 == Frei then Just (Position h0 h1 h2 h3 h4 h5 h6 h7 Holz h9) else Nothing,
    if h9 == Frei then Just (Position h0 h1 h2 h3 h4 h5 h6 h7 h8 Holz) else Nothing]

data Gleichung = Gleichung [Position]
    deriving (Eq)
gleichungToPositions (Gleichung positions) = positions
positionsToGleichung positions = Gleichung positions

instance Show Gleichung where
  show (Gleichung positions) =
    foldl (++) "" (map show positions)

wegnehmenGleichung :: [Position] -> [[Position]]
wegnehmenGleichung [] = [[]]
wegnehmenGleichung (p:ps) =
  let positions = wegnehmenPosition p -- aktuelles Zeichen mutieren
      subPositions = wegnehmenGleichung ps -- oder ein folgendes Zeichen mutieren
  in ((map (\ x -> x : ps) positions) ++ (map (\ xs -> p : xs) subPositions))

hinzufuegenGleichung :: [Position] -> [[Position]]
hinzufuegenGleichung [] = [[]]
hinzufuegenGleichung (p:ps) =
  ((map (\ x -> x : ps) (hinzufuegenPosition p)) ++ -- aktuelles Zeichen mutieren
  (map (\ xs -> p : xs) (hinzufuegenGleichung ps))) -- oder ein folgendes Zeichen mutieren

umlegenGleichung :: Gleichung -> [Gleichung]
umlegenGleichung gl = concatMap (\g -> map positionsToGleichung $ hinzufuegenGleichung g) (wegnehmenGleichung $ gleichungToPositions  gl)

umlegenGleichung' :: Gleichung -> [Gleichung]
umlegenGleichung' gl = concatMap (\g -> map positionsToGleichung $ wegnehmenGleichung g) (hinzufuegenGleichung $ gleichungToPositions  gl)

isBalanced :: Gleichung -> Bool
isBalanced g = isValid g
  && let ps = gleichungToPositions g
         gleichPos = head $ findIndices (\p -> p==gleich) ps
         s1 = take gleichPos ps
         s2 = drop (1+gleichPos) ps
    in (berechne s1) == (berechne s2)

isValid :: Gleichung -> Bool
isValid g =
  all (\ p -> p == z0 || p == z1 || p == z2 || p == z3 || p == z4
           || p == z5 || p == z6 || p == z7 || p == z8 || p == z9
           || p == plus || p == minus || p == gleich || p == leer) (gleichungToPositions g)
  && 1 == (length $ findIndices (\p -> p==gleich) (gleichungToPositions g))
  && False == isInfixOf [minus, gleich] (gleichungToPositions g)
  && False == isInfixOf [plus, gleich] (gleichungToPositions g)
  && minus /= last (gleichungToPositions g)
  && plus /= last (gleichungToPositions g)

berechne :: [Position] -> Int
berechne s =
  let
      plusPos = findIndices (\ p -> p == plus) s
      minusPos = findIndices (\ p -> p == minus) s
      leerPos = findIndices (\ p -> p == leer) s
  in  if 0 == (length s) then 0
      else if 0 < (length plusPos) then (berechne (take (head plusPos) s)) + (berechne (drop (1+(head plusPos)) s))
      else if 0 < (length minusPos) then (berechne (take (head minusPos) s)) - (berechne (drop (1+(head minusPos)) s))
      else if 0 < (length leerPos) then (berechne ((take (head leerPos) s) ++ (drop (1+(head leerPos)) s)))
      else if 1 == (length s) then head $ findIndices (\e -> e == (head s)) [z0, z1, z2, z3, z4, z5, z6, z7, z8, z9]
      else ((berechne [head s]) * 10^(length $ tail s)) + (berechne (tail s))

rotatePosition :: Position -> Position
rotatePosition z | z == z1 = z1
rotatePosition (Position h0 h1 h2 h3 h4 h5 h6 h7 h8 h9) = Position h9 h8 h7 h6 h4 h5 h3 h2 h1 h0
rotateGleichung g =
    Gleichung $ reverse $ map (\ p -> rotatePosition p) (gleichungToPositions g)


parse :: [Char] -> Gleichung
parse s = positionsToGleichung (map charToPosition s)

charToPosition :: Char -> Position
charToPosition c
  | c == '0' = z0 | c == '1' = z1 | c == '2' = z2 | c == '3' = z3 | c == '4' = z4
  | c == '5' = z5 | c == '6' = z6 | c == '7' = z7 | c == '8' = z8 | c == '9' = z9
  | c == '+' = plus | c == '-' = minus | c == '=' = gleich  | c == ' ' = leer

gleichung = "  185 + 15 = 270  "

main :: IO ()
main = do
  putStrLn $ "Die Lösung für " ++ gleichung
  putStrLn (show (filter isBalanced (umlegenGleichung (parse gleichung))))
  putStrLn (show (filter isBalanced (umlegenGleichung' (parse gleichung))))