Estructuras II Práctica 6

-- EJERCICIO 1
fibSeq : Nat -> Seq Nat
fibSeq n = map (\(a,b,c,d) -> b)
               (first (scan (\(a1, b1, c1, d1), (a2, b2, c2, d2)) -> (a1*a2 + b1*c2, a1*b2 + b1*d2, c1*a2 + d1*c2, c1*b2 + d1*d2)
                            (1,0,0,1) (tabulate (\x -> (1,1,1,0) ) n) ))



-- EJERCICIO 2
aguaHist: Seq Nat -> Nat
reverse: Seq a -> Seq a
reverse seq = tabulate (\x -> nth (lenth seq - x - 1) seq) (length seq)

aguaHist: Seq Nat -> Nat
aguaHist seq = let maxL = fst (scan max 0 seq)
                   maxR = reverse (fst (scan max 0 (reverse seq)))
                   aguas = tabulate (\x -> max 0 ( (min (nth x maxL) (nth x maxR)) - (nth x seq) )) (length seq)
               in reduce (+) 0 aguas



-- EJERCICIO 3
--No confío mucho en esto
data Paren = Open | Close

matchParen' :: Seq Paren -> (Int, Int)
matchParen' s = case showT s of
	                 EMPTY -> (0, 0)
	                 ELT x -> if x == Open then (0, 1) else (1, 0)
	                 Node l r -> let ((closeL, openL), (closeR, openR)) = (matchParen' l, matchParen' r)
	                             in if openL <= closeR then (closeL + closeR - openL, openR)
	                             	                   else (closeL, openR + openL - closeR)

matchParen :: Seq Paren -> Bool
matchParen s = matchParen' s == (0, 0)

matchParenScan :: Seq Paren -> Bool
matchParenScan s = let (seq, result) = (scan (+) 0 (map (\x -> if x == Open then 1 else (-1)) s))
                   in (reduce (&&) True (map (\x -> x > 0) seq)) && (result == 0)



-- EJERCICIO 4
-- Lo escribí en "pseudocódigo" y no tengo idea de si anda.
dist :: (Float, Float) -> (Float, Float) -> Float
dist (x1, y1) (x2, y2) = sqrt ((x1-x2)^2 + (y1-y2)^2)

-- Asumimos que ya vienen ordenados en la componente x
closestPair : Seq (Float, Float) -> Float
closestPair empty = inf
closestPair (singleton x) = inf
closestPair seq = let mitad = div (length seq) 2
                      primerMitad = take mitad seq
                      segundaMitad = drop mitad seq
                      (d1, d2) = (closestPair primerMitad, closestPair segundaMitad)
                      minDist = min d1 d2
                      franjaIzq = filter (\(x,y) -> x >= (fst (head segundaMitad)) - minDist ) primerMitad
                      franjaDer = filter (\(x,y) -> x <= (fst (head segundaMitad)) + minDist ) segundaMitad
                      exhaustive = map (\x -> reduce min inf (map (dist x) franjaDer)) franjaIzq
                  in min minDist (reduce min inf exhaustive)


-- EJERCICIO 5
fScan : (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
fScan (idx1, len1, final1) (idx2, len2, final2) = if (idx1 + len1 == idx2) && (final1 == final2 - len2)
	                                                 then (idx1, len1 + len2, final2)
	                                                 else (idx2, len2, final2)

maxLen : (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
maxLen (i1, l1, f1) (i2, l2, f2) = if l1 > l2 then (i1, l1, f1)
	                                          else (i2, l2, f2)

sccml : Seq Int -> Int
sccml seq = let seqMap = tabulate (\x -> (x, 1, nth x seq) ) (length seq)
                (prefScan, resScan) = scan fScan (0,0,-1) seqMap
                redSeq = reduce maxLen (0,0,-1) prefScan
            in max 0 ( (maxLen redSeq resScan) - 1)



-- EJERCICIO 6
merge : (a -> a -> Ordering) -> Seq a -> Seq a -> Seq a
merge orden empty seqB = seqB
merge orden seqA empty = seqA
merge orden seqA seqB = if orden (nth seqA 0) (nth seqB 0) == LOWER
                           then append (take seqA 1) (merge orden (drop seqA 1) seqB)
                           else append (take seqB 1) (merge orden seqA (drop seqB 1))

sort: (a -> a -> Ordering) -> Seq a -> Seq a
sort orden seq = reduce (merge orden) empty (map (\x -> singleton x) seq)

--Supongo que no me pasan una secuencia vacía
maxE : (a -> a -> Ordering) -> Seq a -> a
maxE orden seq = reduce (\x y -> if orden x y == GREATER then x else y) (take seq 1) seq

--Supongo que no me pasan una secuencia vacía
maxS : (a -> a -> Ordering) -> Seq a -> Nat
maxS orden seq = snd (reduce (\x y -> if orden (x,ix) (y,iy) == GREATER then (x,ix) else (y,iy)) (nths seq 0, 0)
                 (tabulate (\i -> (nths seq i, i) ) (length seq))

-- Esta está implementada para testearla, pero la idea es la misma
group :: [Int] -> [Int]
group xs = reduce (\x y -> if nthS x ((lengthS x) - 1) == head y
                               then (x ++ tail y)
                               else (x ++ y)) [] (map (\x -> [x]) xs)

-- Implementada por las mismas razones
fAux :: (a,b) -> (a, [b])
fAux (k, d) = (k, [d])
collect :: Ord a => [(a,b)] -> [(a,[b])]
collect seq =   reduce (\x y -> if length x == 0 then y
                                else if fst (last x) == fst (head y)
                                        then (init x) ++ [(fst (head y), (snd (last x)) ++ (snd (head y)) )] ++ (tail y)
                                        else x ++ y)
                []
                (map (\x -> [fAux x]) (sort (\(k1, d1) (k2, d2) -> k1 <= k2) seq))



-- EJERCICIO 7
datosIngreso : Seq (String, Seq Int) -> Seq (Int, Int)
datosIngreso s = mapCollectReduce apv red s

mapCollectReduce apv red s = let pairs = join (map apv s)
                                 groups = collect pairs
                             in map red groups

apv (string, seq) = let (suma, maxima) = reduce (\(x1, x2), (y1, y2) -> (x1 + y1, max x2 y2)) (0, 0) (map (\x -> (x, x)) seq)
                        promedio = div suma (length seq)
                    in if promedio >= 70
                    	  then singletonS ("Ingresa", maxima)
                       else if promedio >= 50
                       	       then singletonS  ("Lista de Espera", maxima)
                       	       else singletonS  ("No Ingresa", maxima)

red (string, seq) = (length seq, reduce max 0 seq)



-- EJERCICIO 8
mapCollectReduce apv red s = let pairs = join (map apv s)
                                 groups = collect pairs
                             in map red groups

countCaract :Seq (Seq Char) -> Seq (Char,Int)
countCaract s = mapCollectReduce apv red s

apv seq = map (\l -> (l, 1)) seq
red (caracter, seq) = (caracter, reduce (+) 0 seq)


huffman :Seq (Seq Char) -> Seq (Int, Seq Char)
huffman s = collect (map (\(x, y) -> (y, x)) (countCaract s))