1votos

Listín telefónico funcional en Haskell

por josejuan hace 6 años

Debo reconocer que ha sido mas fácil de lo que pensaba. El código seguro que es mucho más verbose de lo necesario, pero por algo se empieza :) Por otro lado, lo suyo es separar el código en al menos tres archivos (estructuras, código puro, código impuro) pero aquí (en solveet) es más cómodo poner todo junto.

Este es muy sencillo en un lenguaje imperativo, pero a mi me parece bastante complicado en uno funcional "PURO". El requisito es usar "inmutabilidad" y "transparencia referencial". No vale usar "workarounds" para evitar la inmutabilidad y/o transparencia (eg. un subsistema de eventos). Si lo pongo en Solveet me obligo a intentar hacerlo (a ver que tal...).

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
import System.IO 
 
-- Estructuras de datos ========================================== 
 
data Contact = Contact { 
        code :: Int, 
        name :: String, 
        phone :: Int 
    } deriving (Read, Show) 
 
data AppData = AppData { 
        currentPath :: String, 
        nextCode :: Int, 
        contacts :: [Contact] 
    } deriving (Read, Show) 
 
-- Operaciones sobre los datos ==================================== 
 
getContactCode (Contact {code = code', name = _, phone = _}) = code' 
 
emptyData = AppData {currentPath = "", nextCode = 1, contacts = []} 
 
getNewCode (AppData {currentPath = currentPath', nextCode = nextCode', contacts = contacts'}) = 
    (nextCode', AppData {currentPath = currentPath', nextCode = nextCode' + 1, contacts = contacts'}) 
 
getCurrentPath (AppData {currentPath = currentPath', nextCode = _, contacts = _}) = currentPath' 
setCurrentPath (AppData {currentPath = _, nextCode = nextCode', contacts = contacts'}) currentPath' = 
    AppData {currentPath = currentPath', nextCode = nextCode', contacts = contacts'} 
 
getContacts (AppData {currentPath = _, nextCode = _, contacts = contacts'}) = contacts' 
setContacts (AppData {currentPath = currentPath', nextCode = nextCode', contacts = _}) contacts' = 
    AppData {currentPath = currentPath', nextCode = nextCode', contacts = contacts'} 
 
addContact adata name phone = setContacts adata' (newContact:contacts) 
    where    newContact = Contact {code = newCode, name = name, phone = phone} 
        contacts = getContacts adata 
        (newCode, adata') = getNewCode adata 
 
removeContact adata contactCode = setContacts adata $ filter ((contactCode /=).getContactCode) $ getContacts adata 
 
-- Código impuro IO ================================================ 
 
main = do 
    hSetBuffering stdout NoBuffering 
    app emptyData 
 
app adata = do 
    screenMain 
    o <- getLine 
    case head o of 
        '1' -> saveToFile adata >>= app 
        '2' -> readFromFile adata >>= app 
        '3' -> app emptyData 
        '4' -> listContacts adata >>= app 
        '5' -> return $ adata 
 
inputPath msg current = do 
    clearScreen 
    putStrLn $ "Current file path: " ++ current 
    putStr $ "Input file path to " ++ msg ++ ": " 
    f <- getLine 
    return f 
 
saveToFile adata = do 
    let f = getCurrentPath adata 
    f' <- inputPath "read" f 
    d <- readFile f' 
    return $ setCurrentPath (read d) f' 
 
readFromFile adata = do 
    let f = getCurrentPath adata 
    f' <- inputPath "write" f 
    writeFile f' $ show adata 
    return $ setCurrentPath adata f' 
 
listContacts adata = do 
    screenContacts adata 
    o <- getLine 
    case head o of 
        '1' -> editContact adata >>= listContacts 
        '2' -> deleteContact adata >>= listContacts 
        '3' -> insertContact adata >>= listContacts 
        '4' -> return $ adata 
 
getData = do 
    putStr "Enter new name: " 
    name <- getLine 
    putStr "Enter new phone number: " 
    phone <- getLine 
    return (name, phone) 
 
insertContact adata = do 
    clearScreen 
    (name, phone) <- getData 
    return $ addContact adata name $ read phone 
 
editContact adata = do 
        c <- inputCode "edit" 
        (name'', phone'') <- getData 
        let cl = getContacts adata 
        return $ setContacts adata $ cl' cl (c, name'', read phone'') 
        where   cl' [] _ = [] 
                cl' (Contact {code = code', name = name', phone = phone'}:xs) (c, name'', phone'') = f : cl' xs (c, name'', phone'') 
                        where f = if code' == c 
                                then Contact {code = code', name = name'', phone = phone''} 
                                else Contact {code = code', name = name', phone = phone'} 
 
deleteContact adata = do 
    c <- inputCode "delete" 
    return $ removeContact adata c 
 
inputCode :: String -> IO Int 
inputCode msg = do 
    clearScreen 
    putStr $ "Input code to " ++ msg ++ ": " 
    c <- getLine 
    return $ read c 
 
 
-- Screens ====================================== 
 
clearScreen = c 100 
    where    c 0 = return () 
        c n = c (n - 1) >> putStrLn "" 
 
screenMain = do 
    clearScreen 
    putStrLn "1. Leer listín desde el disco." 
    putStrLn "2. Guardar listín en disco." 
    putStrLn "3. Crear nuevo listín." 
    putStrLn "4. Listar contactos." 
    putStrLn "5. Salir." 
    putStr "Enter option: " 
 
screenContacts adata = do 
    clearScreen 
    formatContacts $ getContacts adata 
    putStrLn "1. Editar contacto." 
    putStrLn "2. Eliminar contacto." 
    putStrLn "3. Insertar contacto." 
    putStrLn "4. Volver." 
    putStr "Enter option: " 
 
formatContacts [] = putStrLn "La lista de contactos está vacía." >> putStrLn "" 
formatContacts xs = putStrLn "Lista de contactos:" >> f xs >> putStrLn "" 
    where    f [] = putStrLn "" 
                f (Contact {code = code', name = name', phone = phone'}:ys) = do 
                        putStrLn $ show code' ++ ", " ++ name' ++ ", " ++ show phone' 
                        f ys 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.