ghc/tests/programs/waugh_neural/Main.lhs

   1 Main.hs for backprop simulation
   2 Written by Sam Waugh
   3 Date started: 10th November 1992.
   4
   5 This main module initialises, runs and gets results from the
   6 backpropagation functions and values.
   7
   8 > import BpGen
   9 > import ReadLists (readWhiteList)
  10 > import {-fool mkdependHS-}
  11 >        Printf
  12
  13 -------------------------------------------------------------------------------
  14 |                               Constant Values                               |
  15 -------------------------------------------------------------------------------
  16 The following constants set the training problem and parameters:
  17   name          - the name of the file
  18   dimensions    - the layered network topology
  19   eta           - the learning rate
  20   accepterr     - the level of error acceptable to stop training
  21   epochs        - the maximum number of epochs in training
  22
  23 > name          :: String
  24 > name          = "xor"
  25 > dimensions    :: Dimensions
  26 > dimensions    = [2,2,1]
  27 > eta,accepterr :: Double
  28 > eta           = 1.0
  29 > accepterr     = 0.001
  30 > epochs        :: Int
  31 > epochs        = 10000
  32
  33
  34 -------------------------------------------------------------------------------
  35 |                       IO and Main Program                                   |
  36 -------------------------------------------------------------------------------
  37
  38 > main = do
  39 >   s <- readFile name
  40 >   putStr (program s "")
  41
  42 > program :: String -> ShowS
  43 > program s
  44 >   = let egs       = readegs s
  45 >         ws        = randweights dimensions
  46 >         rs        = selectegs (length egs)
  47 >         (ws',res) = trainweights egs ws epochs accepterr eta rs
  48 >     in
  49 >     showString "Examples:\n"
  50 >     . showegs egs
  51 >     . showString "Classification:\n"
  52 >     . showresults egs ws
  53 >     . showString "Training Error:\n"
  54 >     . showerr res
  55 >     . showString "Trained Classification:\n"
  56 >     . showresults egs ws'
  57
  58 > {- ORIG:
  59 > program :: String -> String
  60 > program s
  61 >   = _scc_ "program" (
  62 >     let egs       = _scc_ "readegs" readegs s
  63 >         ws        = _scc_ "randweights" randweights dimensions
  64 >         rs        = _scc_ "selectegs" selectegs (length egs)
  65 >         (ws',res) = _scc_ "trainweights" trainweights egs ws epochs accepterr eta rs
  66 >     in "Examples:\n"
  67 >     ++ _scc_ "showegs" showegs egs
  68 >     ++ "Classification:\n"
  69 >     ++ _scc_ "showresults" showresults egs ws
  70 >     ++ "Training Error:\n"
  71 >     ++ _scc_ "showerr" showerr res
  72 >     ++ "Trained Classification:\n"
  73 >     ++ _scc_ "showresults2" showresults egs ws'
  74 >     )
  75 > -}
  76
  77 -------------------------------------------------------------------------------
  78 |                               Show Functions                                |
  79 -------------------------------------------------------------------------------
  80
  81 > showdouble :: Double -> ShowS
  82 > showdouble v = showString (printf "%6.4f " [UDouble v])
  83
  84 > showdoubles :: [Double] -> ShowS
  85 > showdoubles []     = showString ""
  86 > showdoubles (v:vs) = showdouble v . showdoubles vs
  87
  88 > showegs :: Egs -> ShowS
  89 > showegs [] = showString "\n"
  90 > showegs ((x,t):egs)
  91 >       = showdoubles x . showString " " . showdoubles t . showString "\n" . showegs egs
  92
  93 > showresults :: Egs -> Weights -> ShowS
  94 > showresults [] _ = showString "\n"
  95 > showresults ((x,t):egs) ws
  96 >   = let y = last (classeg ws x)
  97 >         p = maxplace y
  98 >         c = maxplace t
  99 >     in shows p . showString "  " . showdouble (y!!p) . showString "    " .
 100 >        shows c . showString "  " . showdouble (t!!c) . showString "\n" . showresults egs ws
 101
 102 > showerr :: [Double] -> ShowS
 103 > showerr [] = showString ""
 104 > showerr (x:xs) = showerr xs . showdouble x . showString "\n"
 105
 106 > showweights :: Weights -> ShowS
 107 > showweights [] = showString "\n"
 108 > showweights (w:ws) = showweight w . showweights ws
 109
 110 > showweight, showl :: Weight -> ShowS
 111 > showweight []     = showString "[]\n"
 112 > showweight (x:xs) = showString "[" . showdoubles x . showl xs
 113
 114 > showl []     = showString "]\n"
 115 > showl (x:xs) = showString "\n " . showdoubles x . showl xs
 116
 117 > {- ORIG:
 118 > showdouble :: Double -> String
 119 > showdouble v = printf "%6.4f " [UDouble v]
 120
 121 > showdoubles :: [Double] -> String
 122 > showdoubles []     = ""
 123 > showdoubles (v:vs) = showdouble v ++ showdoubles vs
 124
 125 > showegs :: Egs -> String
 126 > showegs [] = "\n"
 127 > showegs ((x,t):egs)
 128 >       = (showdoubles x) ++ " " ++ (showdoubles t) ++ "\n" ++ showegs egs
 129
 130 > showresults :: Egs -> Weights -> String
 131 > showresults [] _ = "\n"
 132 > showresults ((x,t):egs) ws
 133 >   = let y = last (classeg ws x)
 134 >         p = maxplace y
 135 >         c = maxplace t
 136 >     in show p ++ "  " ++ showdouble (y!!p) ++ "    " ++
 137 >        show c ++ "  " ++ showdouble (t!!c) ++ "\n"   ++ showresults egs ws
 138
 139 > showerr :: [Double] -> String
 140 > showerr [] = ""
 141 > showerr (x:xs) = showerr xs ++ showdouble x ++ "\n"
 142
 143 > showweights :: Weights -> String
 144 > showweights [] = "\n"
 145 > showweights (w:ws) = showweight w ++ showweights ws
 146 > showweight, showl :: Weight -> String
 147 > showweight []     = "[]\n"
 148 > showweight (x:xs) = "["    ++ showdoubles x ++ showl xs
 149 > showl []     = "]\n"
 150 > showl (x:xs) = "\n " ++ showdoubles x ++ showl xs
 151 > -}
 152
 153 -------------------------------------------------------------------------------
 154 |                       Data Reading Functions                                |
 155 -------------------------------------------------------------------------------
 156
 157 > readegs :: String -> Egs
 158 > readegs s = readData (readWhiteList s)
 159
 160 > readData :: [Double] -> Egs
 161 > readData [] = []
 162 > readData bs = let (inp, bs')  = splitAt (head dimensions) bs
 163 >                   (out, bs'') = splitAt (last dimensions) bs'
 164 >               in (inp,out) : (readData bs'')