{-------------------------------------------------------------------------------------------------- solutionSet.txt ~ rev. 2011.08.11 XGB Web and Software Design ~ www.xgbdesign.com This program chiefly exercises higher-order functions, and extensive list-processing, in Haskell. The objective is to select from a number of mathematical functions on the Cartesian coordinate plane; specify a domain for the function chosen; and output a neatly formatted solution set for the given function and domain. Additionally, the program is designed to exploit a variety of Haskell's features while using only straighforward, out-of-the-box notions presented in the Standard Prelude (no imports). You'll see anonymous functions and lambda notation; putting functions in a list, and invoking them by number rather than by name; plus function composition, sections and partial function application, a fold, some point-free style, and "nice IO." PLEASE NOTE: This source code file has been saved with the ".txt" extension to obviate browser difficulties, particularly with Internet Explorer. To compile and run this code, just copy and paste this text into a new document, but save the file with the extension ".hs" PLEASE NOTE: This code is licensed under the terms of the GNU General Public License, Version 3 (http://www.gnu.org/copyleft/gpl.html#header). You are free to use and modify this source code, but if you do, kindly cite XGB Web and Software Design, whether in a link from your website, or or in your own source code. Thanks! --------------------------------------------------------------------------------------------------} -- "Impure" IO functions: ------------------------------------------------------------------------- main :: IO () main = do selection <- getMenuSelection if valid selection then do makeSolutionSet selection promptToRepeat else invalidSelection getMenuSelection :: IO Int getMenuSelection = do putStrLn "\nPlease select a function from the following menu;" putStrLn "note the arguments needed, and their order of application:" putStrLn " (1) Line: slope, y-intercept" putStrLn " (2) Line: algebraic coefficients a, b, c" putStrLn " (3) Hyperbola: amplitude" putStrLn " (4) Parabola: algebraic coefficients a, b, c" putStrLn " (5) Sine: units*, period, amplitude, phase shift**" putStrLn " (6) Cosine: units*, period, amplitude, phase shift**" putStrLn " (7) Tangent: units*, period, amplitude, phase shift**" putStrLn " (8) Hyperbolic Sine: no arguments (or ANY arguments!)" putStrLn " (9) Hyperbolic Cosine: no arguments (or ANY arguments!)" putStrLn " (10) Hyperbolic Tangent: no arguments (or ANY arguments!)" putStrLn " (11) Catenary (about the y-axis): scaling parameter a (same as y-intercept)" putStrLn " (12) Circle: radius, center coordinates a and b" putStrLn " (13) Superellipse (about the origin): horizontal semi-axis, vertical semi-axis, exponent" putStrLn " * Enter -> Degrees: 0 Radians: 1 Grads: 2" putStrLn " ** Enter phase shift and domain in terms of the units you've chosen" entry <- getLine return $ read entry makeSolutionSet :: Int -> IO () makeSolutionSet i = do -- Inputs: putStrLn $ "\nNow enter the arguments, separated by spaces:" argsStr <- getLine putStrLn $ "\nNow enter the elements that determine the domain: the lower bound," putStrLn $ "the upper bound, and the desired interval, separated by spaces:" domStr <- getLine putStrLn $ "\nLastly, enter the degree of precision desired, from 0 to 16 decimal places:" p <- fmap read getLine -- Output: let fun = (fs !! i) . fmap read . words $ argsStr dom = domain . fmap read . words $ domStr putStrLn $ ssToString fun dom p promptToRepeat :: IO () promptToRepeat = do putStrLn "Would you like to create another solution set? (y/_)" reply <- getLine if reply `elem` ["Y","y","Yes","yes"] then main else putStrLn "Exiting program...\n" invalidSelection :: IO () invalidSelection = do putStrLn $ "\n *** INVALID ENTRY: Your choice must be in the range 1 through " ++ show lastf ++ ". ***" main -- "Pure" functions: --------------------------------------------------------------------------------------- -- This function checks to see whether the chosen function index -- is within the range of available functions in fs: valid :: Int -> Bool valid e = e `elem` [0..lastf] -- This function takes a list containing the lower bound, upper bound, and -- interval of a proposed domain, and returns a list representing the domain: domain :: (Num a, Enum a) => [a] -> [a] domain [xa, xb, i] = [xa, xa + i..xb] -- This is a higher-order function that takes a function and a list of x-values (the domain), -- and returns another list containing pairs of x- and y-values--i.e., the "solution set" of f. -- Note also the use of point-free style (i.e., the domain parameter is implied): solutionSet :: (t -> t1) -> [t] -> [(t, t1)] solutionSet f = foldr (\x acc -> (x, f x) : acc) [] -- This function converts an (x, y) pair into a string representation of the pair. -- The numbers in the pair are adjusted for precision according to the parameter p: xyToString :: (Integral b, RealFrac t, RealFrac t1) => b -> (t, t1) -> String xyToString p (x, y) = concat [xRep, spaces xRep, yRep, "\n"] where xRep = rep "x" x yRep = rep "y" y rep label n = concat [" ", label, ": ", (show . precision p) n] spaces str = replicate (14 - length str) ' ' -- This is a higher-order function that takes a function, a domain for the function, and the -- desired precision, and returns a string representation of the function's solution set. -- Except in extreme cases perhaps, the x- and y-values will be in perfect alignment: ssToString :: (Integral b, RealFrac t, RealFrac t1) => (t -> t1) -> [t] -> b -> String ssToString f dom p = "\n HERE'S THE SOLUTION SET:\n\n" ++ (concat . map (xyToString p) . solutionSet f) dom -- This function takes the number of decimal places desired, and -- the number to be "rounded," and returns the rounded number: precision :: (Integral b, RealFrac a) => b -> a -> a precision places n = fromIntegral (floor (n * factor + 0.5)) / factor where factor = 10 ^ places -- Now let's define an inventory of anonymous functions to play with, and keep them inside a list. -- To ensure that the functions are all of the same type, the parameters of each are artificially -- placed in a list (which is, happily, also the result of the composition 'fmap read . words' -- applied to the string of arguments input by the user): fs :: (Floating a, RealFrac a) => [[a] -> a -> a] fs = [ \ _ x -> 0, -- The "zeroth element" of the list--a placeholder, but a legitimate function nonetheless! \[m,b] x -> m * x + b, -- Line (slope, y-intercept) \[a,b,c] x -> (a * x + c) / (-b), -- Line (algebraic coefficients a, b, c) \[k] x -> k / x, -- Hyperbola \[a,b,c] x -> a * x * x + b * x + c, -- Parabola \[u,p,a,s] theta -> trig sin [u,p,a,s] theta, -- Sine \[u,p,a,s] theta -> trig cos [u,p,a,s] theta, -- Cosine \[u,p,a,s] theta -> trig tan [u,p,a,s] theta, -- Tangent \ _ x -> (exp x - exp (-x)) / 2, -- Hyperbolic sine \ _ x -> (exp x + exp (-x)) / 2, -- Hyperbolic cosine \ _ x -> (exp x - exp (-x)) / (exp x + exp (-x)), -- Hyperbolic tangent \[a] x -> a * (exp (x / a) + exp ((-x) / a)) / 2, -- Catenary (about the y-axis) \[r,a,b] x -> (r * r - (x - a) * (x - a)) ** 0.5 + b, -- Circle \[a,b,n] x -> b * (1 - abs (x / a) ** n) ** (1 / n) -- Superellipse (about the origin) ] -- Here's a function to allow easy expansion of the function list: lastf :: Int lastf = length fs - 1 -- Note that 'trig' is itself a higher-order function whose first argument is one of the -- trigonometric functions 'sin,' 'cos,' and 'tan,' and which processes that function's -- output with respect to units along the domain, the period, amplitude, and phase shift: trig :: (Floating a, RealFrac a) => (a -> a) -> [a] -> a -> a trig f [units, per, amp, shift] theta = amp * f theta' where theta' = per * toRadians units (theta - shift) toRadians 0 v = v * pi / 180 -- Degrees to radians toRadians 2 v = v * pi / 200 -- Grads to radians toRadians _ v = v -- Radians to radians