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