Programming challenge: wildcard exclusion in cartesian products

[Tomasz Zielonka]

wkehowski at cox.net wrote:
> The python code below generates a cartesian product subject to any
> logical combination of wildcard exclusions. For example, suppose I want
> to generate a cartesian product S^n, n>=3, of [a,b,c,d] that excludes
> '*a*b*' and '*c*d*a*'. See below for details.
>
> CHALLENGE: generate an equivalent in ruby, lisp, haskell, ocaml, or in
> a CAS like maple or mathematica.

What is your goal? You want to learn or to cause a flamewar? ;-)

Anyway, I found the problem entertaining, so here you go, here is my
Haskell code. It could be shorter if I didn't care about performance and
wrote in specification style. It's not very efficient either, because it
will generate all lists matching the given patterns.

In GHCi you can test it by:

    $ ghci
    :l WildCartesian.hs
    test

I apologise for the lack of comments.

----8<--------8<--------8<--------8<--------8<--------8<--------8<--------8<----
module WildCartesian where

import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad
import Control.Exception (assert)
import Maybe
import List

data Pat a = All | Lit a deriving Show

generateMatching :: (Ord a) => Int -> Set a -> [Pat a] -> [[a]]
generateMatching 0   _        []    = [[]]
generateMatching 0   _        (_:_) = []
generateMatching len alphabet (Lit x : ps)
    | x `Set.member` alphabet =
        [ (x : xs) | xs <- generateMatching (len - 1) alphabet ps ]
    | otherwise =
        [ ]
generateMatching len alphabet (All : ps) =
    [ (x : xs)
    | x <- Set.toList alphabet
    , xs <- unionSorted
                (generateMatching (len - 1) alphabet ps)
                (generateMatching (len - 1) alphabet (All : ps)) ]
    `unionSorted`
    generateMatching len alphabet ps
generateMatching _   _        [] = []

generateNotMatching :: (Ord a) => [a] -> Int -> [[Pat a]] -> [[a]]
generateNotMatching alphabet len patterns =
    generateMatching len alphaSet [All]
    `subtractSorted`
    foldr unionSorted []
        (map (generateMatching len alphaSet .  simplifyPat) patterns)
  where
    alphaSet = Set.fromList alphabet

simplifyPat (All : All : ps) = simplifyPat (All : ps)
simplifyPat (p : ps) = p : simplifyPat ps
simplifyPat [] = []

joinSorted :: Ord a => [a] -> [a] -> [(Maybe a, Maybe a)]
joinSorted (x1:x2:_) _ | assert (x1 < x2) False = undefined
joinSorted _ (y1:y2:_) | assert (y1 < y2) False = undefined
joinSorted (x:xs) (y:ys) =
    case x `compare` y of
        LT -> (Just x, Nothing) : joinSorted xs (y:ys)
        EQ -> (Just x, Just y)  : joinSorted xs ys
        GT -> (Nothing, Just y) : joinSorted (x:xs) ys
joinSorted (x:xs) [] = (Just x, Nothing) : joinSorted xs []
joinSorted [] (y:ys) = (Nothing, Just y) : joinSorted [] ys
joinSorted [] []     = []

unionSorted :: Ord a => [a] -> [a] -> [a]
unionSorted xs ys = catMaybes (map (uncurry mplus) (joinSorted xs ys))

subtractSorted :: Ord a => [a] -> [a] -> [a]
subtractSorted xs ys = catMaybes (map f (joinSorted xs ys))
  where
    f (Just x, Nothing) = Just x
    f _ = Nothing

test = do
    t [1,2] 3 [[Lit 1, All, Lit 2]]
    t ['a','b'] 3 [[Lit 'a', All, Lit 'b'], [Lit 'b', All, Lit 'a']]
    t [1,2] 3 [[Lit 1, All, Lit 2], [Lit 2, All, Lit 1]]
  where
    t a b c = do
        putStrLn (concat (intersperse " " ["generateMatching", show a, show b, show c]))
        mapM_ (putStrLn . ("  "++) . show) (generateNotMatching a b c)
----8<--------8<--------8<--------8<--------8<--------8<--------8<--------8<----

Best regards
Tomasz

-- 
I am searching for programmers who are good at least in
(Haskell || ML) && (Linux || FreeBSD || math)
for work in Warsaw, Poland