Hello everyone,
I just implemented an Artificial Neural Network but I'm having a serious
memory leak. I was very careful of using tail recursion all over my code,
but for some reason (a.k.a lazyness) my program is misusing incredible
ammounts of RAM. I read the whole chapter 25 of Real World Haskell trying to
find a solution with no luck. Maybe somebody can take a look at the code to
help me out with this problem, I would really appreciate it.
Thanks A LOT in advance,
Hector Guilarte
Ps: The file is also attached
Ps2: The code is written in Spanglish, sorry for that, I'm working on that
bad habbit...
module Main where
import Control.Monad
import System.IO
import qualified Random
import System.IO.Unsafe
import System.Environment
import Data.List
data ANN = ANN Layer Layer Layer -- ^ Red Neuronal de 3 capas
deriving (Eq, Show)
type Layer = [Neuron] -- ^ Lista de Neuronas que conforman la capa
data Neuron = Neuron [(Float,Float)] Float -- ^ Lista de (pesos,xs) y umbral
asociado
deriving (Eq, Show)
neurona:: Neuron -> -- ^ [(Pesos,Xs)] y Umbral
Float
neurona (Neuron entrada umbral) =
let entradaTupla = unzip entrada
pesos = fst entradaTupla
xs = snd entradaTupla
suma = foldl' (+) (-umbral) (zipWith (*) xs pesos)
in sigmoidal suma
neurona2:: [(Float,Float)] -> -- ^ [(Pesos,Xs)]
Float -> -- ^ Umbral
Float
neurona2 valores umbral =
let entradaTupla = unzip valores
pesos = fst entradaTupla
xs = snd entradaTupla
suma = foldl' (+) umbral (zipWith (*) xs pesos)
in sigmoidal suma
-- ANN [] [Neuron [(4.7621,0.9993291),(4.7618,0.94501287)] 7.3061,Neuron
[(6.3917,0.9993291),(6.3917,0.94501287)] 2.8441] [Neuron
[(-10.3788,0.9993291),(9.7691,0.94501287)] 4.5589]
sigmoidal:: Float -> Float
sigmoidal x = 1 / (1 + (exp (-x)))
main:: IO()
main = do
-- nombreArchivo <- getArgs
-- archivo <- readFile (head nombreArchivo)
pesos <- pesosIniciales 10000
randomXs <- generarRandomXs 5000
randomYs <- generarRandomYs 5000
let conjunto = generar 200 0 0 randomXs randomYs []
--print conjunto
-- let lista = parsearString archivo [[]]
-- let splitted = split lista []
let (a,b,c) = (unzip3 (take 200 conjunto))
--let (a,b,c) = ([0,1,0,1],[0,0,1,1],[0,1,1,0])
let ejemplos = zipWith (ajustarEjemplos) a b
-- print ejemplos
let nuevaRed = armarRed 2 8 1 pesos
let entrenada = train nuevaRed ejemplos c
let redInicializada = map (iniciarXsRed entrenada) ejemplos
let resultados = map resultadoRed1Output (map evaluarRed
redInicializada)
print nuevaRed
print entrenada
print resultados
return ()
ajustarEjemplos:: Float -> Float -> [Float]
ajustarEjemplos a b = [a,b]
train:: ANN -> [[Float]] -> [Float] -> ANN
train red ejemplosTodos esperadosTodos =
let entrenado = entrenamiento red ejemplosTodos esperadosTodos [] 200
squaredErrors = snd entrenado
in if squaredErrors < 3 then fst entrenado
else train (fst entrenado) ejemplosTodos esperadosTodos
-- ENTRENAMIENTO
entrenamiento:: ANN -> [[Float]] -> [Float] -> [Float] -> Int -> (ANN,Float)
entrenamiento red _ _ accum 0 =
let squaredErrors = foldl' (+) 0 (map (**2) accum)
in (red,squaredErrors)
entrenamiento red ejemplos esperados accum epoch =
let redInicializada = iniciarXsRed red (head ejemplos)
redEvaluada = evaluarRed redInicializada
redAjustada = ajustarPesos redEvaluada (head esperados)
error = (head esperados) - (resultadoRed1Output redAjustada)
in entrenamiento redAjustada (tail ejemplos) (tail esperados) (accum ++
[error]) (epoch-1)
resultadoRed1Output:: ANN -> Float
resultadoRed1Output (ANN _ _ [(Neuron ((_,xs):_) _)]) = xs
iniciarXsRed:: ANN -> [Float] -> ANN
iniciarXsRed (ANN inputLayer hiddenLayer outputLayer) valores =
let inputNueva = zipWith ajustarXsInput inputLayer valores
in (ANN inputNueva hiddenLayer outputLayer)
ajustarXsInput:: Neuron -> Float -> Neuron
ajustarXsInput (Neuron listaNeurona threshold) xsInput =
let listaNueva = map (ajustarXs xsInput) listaNeurona
in (Neuron listaNueva threshold)
-- FIN ENTRENAMIENTO
pesosIniciales :: Int -> IO [Float]
pesosIniciales n = do
(replicateM n (Random.getStdRandom intervalo))
where
intervalo = Random.randomR (-0.5,0.5)
parsearString:: String -> [String] -> [String]
parsearString [] lista = (tail lista)
parsearString (x:xs) lista = if x == '\n' then parsearString xs ([]:lista)
else parsearString xs (((head lista) ++
[x]):(tail lista))
split:: [String] -> [(Float,Float,Float)] -> [(Float,Float,Float)]
split [] accum = accum
split (x:xs) accum =
let first = readNum x ""
fstNum = read $ fst first
second = readNum (snd first) ""
sndNum = read $ fst second
third = readNum (snd second) ""
thrdNum = if (head $ fst third) == 'A' then 0
else 1
in split xs ([(fstNum,sndNum,thrdNum)]++accum)
readNum:: String -> String -> (String,String)
readNum [] num = ([(head num)],num)
readNum (x:xs) num = if x == ' ' then (num,xs)
else (if x == '\n' then (num,xs)
else readNum xs (num ++ [x])
)
generar:: Int -> Int -> Int -> [Float] -> [Float] -> [(Float,Float,Float)]
-> [(Float,Float,Float)]
generar total dentro fuera randomXs randomYs accum
| total == dentro + fuera = accum
| dentro == total `div` 2 =
let x = head randomXs
y = head randomYs
isDentro = ((x-15)**2) + ((y-6)**2) <= 9
in if isDentro then generar total dentro fuera (tail randomXs) (tail
randomYs) accum
else generar total dentro (fuera+1) (tail randomXs) (tail
randomYs) (accum ++ [(x,y,0)])
| fuera == total `div` 2 =
let x = head randomXs
y = head randomYs
isDentro = ((x-15)**2) + ((y-6)**2) <= 9
in if isDentro then generar total (dentro+1) fuera (tail randomXs)
(tail randomYs) (accum ++ [(x,y,1)])
else generar total dentro fuera (tail randomXs) (tail randomYs)
accum
| otherwise =
let x = head randomXs
y = head randomYs
isDentro = ((x-15)**2) + ((y-6)**2) <= 9
in if isDentro then generar total (dentro+1) fuera (tail randomXs)
(tail randomYs) (accum ++ [(x,y,1)])
else generar total dentro (fuera+1) (tail randomXs) (tail
randomYs) (accum ++ [(x,y,0)])
generarRandomXs :: Int -> IO [Float]
generarRandomXs n = do
(replicateM n (Random.getStdRandom intervalo))
where
intervalo = Random.randomR (0.0,20.0)
generarRandomYs :: Int -> IO [Float]
generarRandomYs n = do
(replicateM n (Random.getStdRandom intervalo))
where
intervalo = Random.randomR (0.0,12.0)
-- ARMAR RED
armarRed:: Int -> Int -> Int -> [Float] -> ANN
armarRed numNeuronasInput numNeuronasHidden numNeuronasOutput randoms =
let layerInput = armarLayerInput numNeuronasInput numNeuronasHidden
randoms []
layerHidden = armarLayerHidden numNeuronasHidden numNeuronasOutput
(snd layerInput) []
layerOutput = armarLayerOutput numNeuronasOutput (snd layerHidden)
[]
in (ANN (fst layerInput) (fst layerHidden) layerOutput)
armarLayerInput:: Int -> Int -> [Float] -> Layer -> (Layer,[Float])
armarLayerInput 0 _ randoms accum = (accum,randoms)
armarLayerInput numNeuronasInput numNeuronasHidden randoms accum =
let listaNeurona = armarListaNeuronasInput numNeuronasHidden randoms []
newRandoms = snd listaNeurona
neurona = [(Neuron (fst listaNeurona) 0)]
in armarLayerInput (numNeuronasInput-1) numNeuronasHidden newRandoms
(accum ++ neurona)
armarLayerHidden:: Int-> Int -> [Float] -> Layer -> (Layer,[Float])
armarLayerHidden 0 _ randoms accum = (accum,randoms)
armarLayerHidden numNeuronasHidden numNeuronasOutput randoms accum =
let listaNeurona = armarListaNeuronasHidden numNeuronasOutput randoms []
neurona = [(Neuron (fst listaNeurona) (head $ snd listaNeurona))]
in armarLayerHidden (numNeuronasHidden-1) numNeuronasOutput (tail $ snd
listaNeurona) (accum ++ neurona)
armarListaNeuronasHidden:: Int -> [Float] -> [(Float,Float)] ->
([(Float,Float)],[Float])
armarListaNeuronasHidden 0 randoms accum = (accum,randoms)
armarListaNeuronasHidden numElems randoms accum =
let pesosYxs = [((head randoms),(head $ tail randoms))]
in armarListaNeuronasHidden (numElems-1) (tail $ tail randoms) (accum ++
pesosYxs)
armarListaNeuronasInput:: Int -> [Float] -> [(Float,Float)] ->
([(Float,Float)],[Float])
armarListaNeuronasInput 0 randoms accum = (accum,randoms)
armarListaNeuronasInput numElems randoms accum =
let pesosYxs = [((head randoms),0)]
in armarListaNeuronasInput (numElems-1) (tail randoms) (accum ++
pesosYxs)
armarLayerOutput:: Int -> [Float] -> Layer -> Layer
armarLayerOutput 0 _ accum = accum
armarLayerOutput numNeuronasHidden randoms accum =
let neurona = [(Neuron [(0,(head randoms))] (head $ tail randoms))]
in armarLayerOutput (numNeuronasHidden-1) (tail $ tail randoms) (accum
++ neurona)
-- FIN ARMAR RED
-- EVALUAR RED
evaluarRed:: ANN -> ANN
evaluarRed (ANN inputLayer hiddenLayer outputLayer) =
let newHidden = ajustarLayer inputLayer hiddenLayer [] 0
newOutput = ajustarLayer newHidden outputLayer [] 0
in (ANN inputLayer newHidden newOutput)
ajustarLayer:: Layer -> Layer -> Layer -> Int -> Layer
ajustarLayer _ [] accum numNeurona = accum
ajustarLayer leftLayer ((Neuron listaNeurona threshold):rightLayer) accum
numNeurona =
let valorLayer = evaluarLayer leftLayer threshold numNeurona
listaNeuronaNew = map (ajustarXs valorLayer) listaNeurona
in ajustarLayer leftLayer rightLayer (accum ++ [(Neuron listaNeuronaNew
threshold)]) (numNeurona+1)
ajustarXs:: Float -> (Float,Float) -> (Float,Float)
ajustarXs xs (peso,_) = (peso,xs)
evaluarLayer:: Layer -> Float -> Int -> Float
evaluarLayer layer threshold numNeurona =
let listaTuplas = extraerTuplaLayer layer numNeurona []
valor = neurona2 listaTuplas threshold
in valor
extraerTuplaLayer:: Layer -> Int -> [(Float,Float)] -> [(Float,Float)]
extraerTuplaLayer [] _ accum = accum
extraerTuplaLayer ((Neuron tupla _):resto) numNeurona accum =
extraerTuplaLayer resto numNeurona (accum ++ [(tupla !! numNeurona)])
-- FIN EVALUAR RED
-- AJUSTAR RED
ajustarPesos:: ANN -> Float -> ANN
ajustarPesos salida@(ANN inputLayer hiddenLayer outputLayer) esperado =
let outputNuevo = map (ajustarPesoOutput esperado) outputLayer
gradientes = snd $ unzip outputNuevo
hiddenNuevo = map (ajustarPesoHidden gradientes) hiddenLayer
gradientes2 = snd $ unzip hiddenNuevo
inputNuevo = map (ajustarPesoInput gradientes2) inputLayer
in (ANN inputNuevo (fst $ unzip hiddenNuevo) (fst $ unzip outputNuevo))
ajustarPesoOutput:: Float -> Neuron -> (Neuron,Float)
ajustarPesoOutput esperado (Neuron [(peso,obtenido)] threshold) =
let error = esperado-obtenido
gradiente = obtenido*(1-obtenido)*error
deltaTheta = tasaAprendizaje*(-1)*gradiente
thresholdNuevo = threshold + deltaTheta
in ((Neuron [(peso,obtenido)] thresholdNuevo),gradiente)
ajustarPesoHidden:: [Float] -> Neuron -> (Neuron,Float)
ajustarPesoHidden gradientes (Neuron listaNeurona threshold) =
let (pesosViejos,xsViejos) = unzip listaNeurona
pesosAjustados = zipWith ajustarPesosHidden listaNeurona gradientes
sumatoriaGradientes = foldl' (+) 0 (zipWith (*) gradientes
pesosViejos)
gradiente = (head xsViejos)*(1-(head xsViejos))*sumatoriaGradientes
thresholdNuevo = tasaAprendizaje*(-1)*gradiente
in ((Neuron pesosAjustados thresholdNuevo),gradiente)
ajustarPesoInput:: [Float] -> Neuron -> Neuron
ajustarPesoInput gradientes (Neuron listaNeurona threshold) =
let (pesosViejos,xsViejos) = unzip listaNeurona
pesosAjustados = zipWith (+) pesosViejos (map (*tasaAprendizaje)
(zipWith (*) gradientes xsViejos))
listaNeuronaNueva = zip pesosAjustados xsViejos
in (Neuron listaNeuronaNueva threshold)
ajustarPesosHidden:: (Float,Float) -> Float -> (Float,Float)
ajustarPesosHidden (pesoViejo,xs) gradiente =
let deltaW = tasaAprendizaje*xs*gradiente
pesoNuevo = pesoViejo + deltaW
in (pesoNuevo,xs)
-- FIN AJUSTAR RED
tasaAprendizaje = 0.1
