Declaratieve Talen/oplossingAlternatieveOrdes

Een volledige oplossing

import Data.List
import Data.Maybe

type Symbool a = a
type Woord a = [Symbool a]
type Orde a = [Symbool a]
data NogVrij a = NogVrij (Symbool a) (Symbool a) deriving (Show)

-- Bereken de orde van een alfabet, gegeven een reeks alfabetisch gesorteerd woorden.
berekenOrde :: (Eq a) => [Woord a] -> [Orde a]
berekenOrde woorden = 
  berekenOrde' (alleSymbolen woorden)
  where berekenOrde' [] = [[]]
        berekenOrde' todo = [s:rest | s <- todo, all (\s2 -> heeftKleinereOrde s s2 (ordes [woorden])) (delete s todo), rest <- berekenOrde' (delete s todo)]

-- Geef alle symbolen die voorkomen in een reeks woorden.   
alleSymbolen :: (Eq a) => [Woord a] -> [Symbool a]
alleSymbolen woorden = nub $ concat woorden

-- Return True als Symbool1 een kleinere orde heeft dan Symbool2. 
-- Return ook True wanneer de orde van Symbool1 tov Symbool2 onbepaald is.
heeftKleinereOrde :: (Eq a) => Symbool a -> Symbool a -> [Orde a] -> Bool
heeftKleinereOrde s1 s2 ordes = 
  all (\w -> isNothing (positie s1 w) || isNothing (positie s2 w) || fromJust (positie s1 w) < fromJust (positie s2 w)) (ordes)
  where positie s woord = elemIndex s woord

-- Bereken alle ordes die afgeleid kunnen worden uit een reeks alfabetisch gesorteerd woorden.
-- We steken eerst het eerst symbool van elk woord in een lijst, vervolgens werken we recursief 
-- verder met de woorden waarvan het eerste symbool gelijk was ...
ordes :: (Eq a) => [[Woord a]] -> [Orde a]
ordes [] = []      
ordes (wl:wls) = (lijstMetEersteSymbolen wl : ordes (map verwijderEersteSymbool (groepeerOpEersteSymbool wl))) ++ ordes wls

-- Steek het eerste symbool van elk woord in een lijst.
lijstMetEersteSymbolen :: (Eq a) => [Woord a] -> [Symbool a]
lijstMetEersteSymbolen woorden = nub $ map (!!0) woorden

-- Verwijder het eerste symbool van elk woord.
verwijderEersteSymbool :: (Eq a) => [Woord a] -> [Woord a]     
verwijderEersteSymbool [] = []
verwijderEersteSymbool ((_:rest):xs)
  | rest == []  = verwijderEersteSymbool xs
  | otherwise   = rest : verwijderEersteSymbool xs
  
-- Maak sublijsten waarbij elke sublijst woorden bevat met hetzelfde beginsymbool.   
groepeerOpEersteSymbool :: (Eq a) => [Woord a] -> [[Woord a]]
groepeerOpEersteSymbool woorden2 = groupBy (\x y -> x!!0 == y!!0) woorden2

-- Detecteer uitgaande van 2 mogelijke ordes wat de vrijheidsgraden nog zijn.
maakUniek :: (Eq a, Ord a) => Orde a -> Orde a -> [NogVrij a]
maakUniek o1 o2 = [NogVrij s1 s2 | s1 <- o1, s2 <- o1, s1 < s2, not (dezelfdeOrde s1 s2) ]
  where dezelfdeOrde s1 s2  
          | heeftKleinereOrde s1 s2 [o1] = heeftKleinereOrde s1 s2 [o2] 
          | otherwise = heeftKleinereOrde s2 s1 [o2] 

--Pieter 13 jan 2014 19:55 (UTC)

Een oplossing

Een oplossing voor het eerste deel van de opgave. Het is een beetje Prolog-generate-and-test geïnspireerd.

 import List
 
 berekenorde::[String]->[String]
 berekenorde woorden = filter (correcteOrde paren) (permuteer letters)
 	where 
 		paren = woordenNaarParen woorden
 		letters = findLettersWoorden woorden
 
 woordenNaarParen::[String]->[(Char, Char)]
 woordenNaarParen list = nub $ woordenNaarParen' list
 woordenNaarParen' [] = []
 woordenNaarParen' (w:t) =
 	verwerkWoorden t w ++ woordenNaarParen t
 
 verwerkWoord::String->String->Maybe (Char, Char)
 verwerkWoord "" _ = Nothing
 verwerkWoord _ "" = Nothing
 verwerkWoord (c1:t1) (c2:t2)
 	| c1 /= c2 = Just (c1,c2)
 	| otherwise = verwerkWoord t1 t2
 
 -- geef woord en zoek naar paren met behulp van andere woordenlijst
 verwerkWoorden::[String]->String->[(Char, Char)]
 verwerkWoorden woorden woord = 
 	[ x | Just x <- map (verwerkWoord woord) woorden]	
 
 
 -- alle letters van alle woorden
 findLettersWoorden::[String]->[Char]
 findLettersWoorden lijst = 
 	nub $ concatenate lijst
 
 correcteOrde::[(Char,Char)]->[Char]->Bool
 correcteOrde [] letters = True
 correcteOrde ((c1,c2):t) letters = 
 	(elemIndex c1 letters) < (elemIndex c2 letters) && correcteOrde t letters
 
 permuteer::[a]->[[a]]
 permuteer [] = [[]]
 permuteer (h:t) = concatMap (permIns h) (permuteer t)
 permIns::a->[a]->[[a]]
 permIns x [] = [[x]]
 permIns x (h:t) = (x:h:t) : map (h:) (permIns x t)
 

--Roald 13 jan 2010 19:55 (UTC)

Een gedeeltelijke oplossing

Hieronder volgt een gedeeltelijke oplossing ('maakuniek' is niet geïmplementeerd)
Het idee is dat de woorden als een soort van 'Boom' geparsed gaan worden:
["ab", "abd", "abc", "ba", "bd", "cc"]
=>
[('a', ["b", "bd", "bc"]), ('b', ["a", "d"]), ('c', ["c"])]  -- (a < b < c)
=>
[('b', ["d", "c"])],
[('a', []), ('d', [])]   -- ( a < d)
[('c', [])]
=>
[('d', []), ('c', [])]   -- (d < c)
=>
Dus de orderingen zijn: (a < b < c) en ( a < d) en (d < c)
=>(a<b<d<c) of (a<d<b<c)


import List

alle_letters :: [String] -> [Char]
alle_letters woordenlijst = foldl union [] woordenlijst

-- vb.:
-- *Main> eerste_letters ["ab", "abd", "abc", "ba", "bd", "cc"]
-- [('a',"b"),('a',"bd"),('a',"bc"),('b',"a"),('b',"d"),('c',"c")]
eerste_letters :: [String] -> [(Char, String)]
eerste_letters xs = [((head x), (tail x)) | x <- (filter (/= []) xs)]

alle_eerste_letters :: [(Char, String)] -> [Char]
alle_eerste_letters lijst = nub [x | (x, s) <- lijst]

-- vb.:
-- *Main> groepeer ["ab", "abd", "abc", "ba", "bd", "cc"]
-- [('a',["b","bd","bc"]),('b',["a","d"]),('c',["c"])]
groepeer :: [String] -> [(Char, [String])]
groepeer xs = let eerste = (eerste_letters xs)
              in let letters = alle_eerste_letters eerste
                  in [ (l, [s | (c,s) <- eerste, c == l]) | l <- letters]
                  
-- vb.:
-- *Main> zoek_orde ["ab", "abd", "abc", "ba", "bd", "cc"]
-- [('a','b'),('d','c'),('a','d'),('b','c')]
zoek_orde :: [String] -> [(Char,Char)]
zoek_orde [] = []
zoek_orde woordenlijst = nub (zoek_orde_rec (groepeer woordenlijst))
                             
zoek_orde_rec :: [(Char, [String])] -> [(Char,Char)]
zoek_orde_rec [] = []
zoek_orde_rec [(c,rest)] = (zoek_orde rest)
zoek_orde_rec ((c1,rest1):(c2,rest2):cs) = ((c1,c2):(zoek_orde rest1)) ++ (zoek_orde rest2) ++ (zoek_orde_rec ((c2,rest2):cs))

berekenorde :: [String] -> [String]
berekenorde woordenlijst = let letters = alle_letters woordenlijst
                               orde = zoek_orde woordenlijst
                            in [ p | p <- (permutations letters), (correcte_ordening p orde)]

correcte_ordening :: String -> [(Char,Char)] -> Bool
correcte_ordening orde lijst = foldl (\a b -> (correcte_orde orde b) && a) True lijst
    
correcte_orde :: String -> (Char,Char) -> Bool
correcte_orde orde (c1,c2)= (findIndex (== c1) orde) < (findIndex (== c2) orde)

permutations :: Eq a => [a] -> [[a]]
permutations [] = [[]]
permutations xs = [ x:ys | x <- xs, ys <- permutations (delete x xs)]

--

Nog één.. (enkel voor 1e deel)

import List

berekenorde::[String]->[String]
berekenorde list = [ alphabet | alphabet<-(perm (allChars list)), volgorde alphabet list]

allChars::[String]->[Char]
allChars [] = []
allChars (list) = verwijderdubbel (concat list)
	where 	verwijderdubbel [] = []
		verwijderdubbel (x:xs) 
			| elem x xs	= verwijderdubbel $ x:(delete x xs)
			| otherwise	= x:(verwijderdubbel xs)

-- permutatie
perm::[Char]->[String]
perm [] = [[]]
perm list = [x:ys| x<-list, ys<-perm (delete x list)]

-- voldoet de String aan de volgorde opgelegd door de list van strings?
-- (mogelijk alphabet)->(lijst woorden)->(correct alphabet?)
volgorde::String->[String]->Bool
volgorde _ [_] = True
volgorde a (x:y:xs)
	| rangschikking a x y	= volgorde a (y:xs) 
	| otherwise		= False

--2 opeenvolgende woorden vergelijken met elkaar geeft uitsluitsel!
-- (mogelijk alphabet)->(woord 1)->(woord 2)->(correct alphabet?)
rangschikking::String->String->String->Bool
rangschikking _ [] _ = True
rangschikking _ _ [] = False
rangschikking (a:as) (v:vs) (w:ws)
	| v == w	= rangschikking (a:as) vs ws
	| a == w	= False
	| a == v	= True
	| otherwise	= rangschikking as (v:vs) (w:ws)

--Andries 17 jan 2012