1 -- Glasgow Haskell 0.403 : FINITE ELEMENT PROGRAM V2
    2 -- **********************************************************************
    3 -- *                                                                    *
    4 -- * FILE NAME : database_array.hs      DATE : 13-3-1991                *
    5 -- *                                                                    *
    6 -- * CONTENTS : Database of source data implemented by array data type. *
    7 -- *                                                                    *
    8 -- * CHANGES  :                                    *
    9 -- *     1. Mon May 27 11:27:43 BST 1991                          *
   10 -- *        Not to scan the source data more times than needed.         * 
   11 -- **********************************************************************
   12 
   13 module Database(idatabase,rdatabase) where
   14 import Array
   15 import Char (isDigit)
   16 
   17 idatabase :: [Char] -> Array Int Int
   18 
   19 idatabase s = listArray (0,n-1) il
   20         where
   21         il = isource s
   22         n = length il
   23 
   24 rdatabase :: [Char] -> Array Int Float
   25 
   26 rdatabase s = listArray (0,n-1) rl
   27         where
   28         rl = rsource s
   29         n = length rl
   30 
   31 isource :: [Char] -> [Int]
   32 
   33 isource s = fst (irsource s) 
   34 
   35 rsource :: [Char] -> [Float]
   36 
   37 rsource s = snd (irsource s)
   38 
   39 irsource s = intreal (words s)
   40 
   41 intreal [] = ([], [])
   42 intreal (x:ls) = if (elem '.' x) then (idb, (realreal x) : rdb)
   43                  else ((intint x) : idb, rdb)
   44                  where
   45                  (idb,rdb) = intreal ls
   46 
   47 {- Mon May 27 11:27:43 BST 1991
   48 isource :: [Char] -> [Int]
   49 
   50 isource s = 
   51         map intint (filter (\x -> not (elem '.' x) ) (words s) )
   52 -}
   53 
   54 intint :: [Char] -> Int
   55 
   56 intint (c:x) =
   57         if (c == '-') then ( - 1 ) * (stoi x)
   58         else if (c=='+') then stoi x
   59         else stoi (c:x)
   60 
   61 stoi :: [Char] -> Int
   62 stoi s  = stoi' (reverse s)
   63 
   64 stoi' [] = 0
   65 stoi' (c:ls) = (stoi' ls) * 10 + ctoi c
   66 
   67 ctoi c =
   68         if ( c =='0' ) then 0
   69         else  if ( c == '1') then 1
   70         else  if ( c == '2') then 2
   71         else  if ( c == '3') then 3
   72         else  if ( c == '4') then 4
   73         else  if ( c == '5') then 5
   74         else  if ( c == '6') then 6
   75         else  if ( c == '7') then 7
   76         else  if ( c == '8') then 8
   77         else  9
   78 
   79 
   80 {- Mon May 27 11:27:43 BST 1991
   81 rsource :: [Char] -> [Float]
   82 
   83 rsource s =
   84         map realreal (filter (\x -> elem '.' x) (words s) )
   85 -}
   86 
   87 realreal :: [Char] -> Float
   88 
   89 realreal (c:x) =
   90         if (c=='-') then ( - 1.0 ) * ( stor x )
   91         else if (c=='+') then stor x
   92         else stor (c:x)
   93 
   94 stor :: [Char] -> Float
   95 stor s = (intpart s) + (floatpart s)
   96 
   97 intpart :: [Char] -> Float
   98 intpart x = intpart' (takeWhile isDigit x)
   99 
  100 intpart' :: [Char] -> Float
  101 intpart' s = intparts (reverse s)
  102 
  103 intparts [] = 0.0
  104 
  105 intparts (c : s) =
  106         (intparts s) * 10.0 + intpartss c
  107 
  108 intpartss  c =
  109         if ( c =='0' ) then 0.0
  110         else  if ( c == '1') then 1.0
  111         else  if ( c == '2') then 2.0
  112         else  if ( c == '3') then 3.0
  113         else  if ( c == '4') then 4.0
  114         else  if ( c == '5') then 5.0
  115         else  if ( c == '6') then 6.0
  116         else  if ( c == '7') then 7.0
  117         else  if ( c == '8') then 8.0
  118         else  9.0
  119 
  120 floatpart :: [Char] -> Float
  121 floatpart x = floatpart' (drop 1 ( dropWhile isDigit x ) )
  122 
  123 floatpart' :: [Char] -> Float
  124 floatpart' s = (intpart' s) / (e10 (length s))
  125 
  126 e10 0 = 1.0
  127 e10 i = 10.0 * (e10 (i - 1))
  128 
  129