Commit 3fb17eef authored by Michael Hanus 's avatar Michael Hanus
Browse files

Tools updated

parent cf2d729e
......@@ -13,6 +13,8 @@ optimize/.cpm/packages/currypath-0.0.1
optimize/.cpm/packages/flatcurry-2.0.0
optimize/.cpm/packages/frontend-exec-0.0.1
optimize/.cpm/packages/propertyfile-0.0.1
optimize/.cpm/packages/random-0.0.1
optimize/.cpm/packages/redblacktree-0.0.1
optimize/.cpm/packages/scc-0.0.1
optimize/.cpm/packages/socket-0.0.1
optimize/.cpm/packages/xml-2.0.0
......
......@@ -20,9 +20,10 @@ module CPM.LookupSet
) where
import List (sortBy, delete, deleteBy)
import TableRBT
import Test.EasyCheck
import Data.Table.RBTree as Table ( TableRBT, empty, lookup, toList,update )
import CPM.Package
------------------------------------------------------------------------------
......@@ -40,7 +41,7 @@ data LookupOptions = LookupOptions
--- The empty lookup set.
emptySet :: LookupSet
emptySet = LookupSet (emptyTableRBT (<=)) defaultOptions
emptySet = LookupSet (empty (<=)) defaultOptions
defaultOptions :: LookupOptions
defaultOptions = LookupOptions []
......@@ -60,7 +61,7 @@ addPackages :: LookupSet -> [Package] -> LookupSource -> LookupSet
addPackages ls pkgs src = foldl (\l p -> addPackage l p src) ls pkgs
allPackages :: LookupSet -> [Package]
allPackages (LookupSet ls _) = map snd $ concat $ map snd $ tableRBT2list ls
allPackages (LookupSet ls _) = map snd $ concat $ map snd $ toList ls
--- Adds a package to a lookup set.
---
......@@ -68,10 +69,10 @@ allPackages (LookupSet ls _) = map snd $ concat $ map snd $ tableRBT2list ls
--- @param p the package to add
--- @param s where is the package spec from?
addPackage :: LookupSet -> Package -> LookupSource -> LookupSet
addPackage (LookupSet ls o) pkg src = case lookupRBT (name pkg) ls of
Nothing -> LookupSet (updateRBT (name pkg) [(src, pkg)] ls) o
addPackage (LookupSet ls o) pkg src = case Table.lookup (name pkg) ls of
Nothing -> LookupSet (update (name pkg) [(src, pkg)] ls) o
Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps
in LookupSet (updateRBT (name pkg) ((src, pkg):ps') ls) o
in LookupSet (update (name pkg) ((src, pkg):ps') ls) o
--- Finds a specific entry (including the source) in the lookup set.
---
......@@ -80,7 +81,7 @@ addPackage (LookupSet ls o) pkg src = case lookupRBT (name pkg) ls of
findEntry :: LookupSet -> Package -> Maybe (LookupSource, Package)
findEntry (LookupSet ls _) p = maybeHead candidates
where
allVersions = lookupRBT (name p) ls
allVersions = Table.lookup (name p) ls
candidates = case allVersions of
Nothing -> []
Just ps -> filter ((packageIdEq p) . snd) ps
......@@ -95,7 +96,7 @@ findEntry (LookupSet ls _) p = maybeHead candidates
findAllVersions :: LookupSet -> String -> Bool -> [Package]
findAllVersions (LookupSet ls o) p pre = localSorted' ++ nonLocalSorted
where
packageVersions = case lookupRBT p ls of
packageVersions = case Table.lookup p ls of
Nothing -> []
Just vs -> vs
onlyLocal = filter isLocal packageVersions
......
......@@ -12,6 +12,7 @@
"currypath" : ">= 0.0.1",
"flatcurry" : ">= 2.0.0",
"propertyfile" : ">= 0.0.1",
"redblacktree" : ">= 0.0.1",
"scc" : ">= 0.0.1",
"socket" : ">= 0.0.1",
"xml" : ">= 2.0.0"
......
......@@ -8,8 +8,9 @@
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
import FlatCurry.Types
import List
import SetRBT
import List ( nub )
import Data.Set.RBTree ( SetRBT, empty, insert, toList, union)
--- Return the type constructors occurring in a type declaration.
dependsDirectlyOnTypes :: TypeDecl -> [QName]
......@@ -31,7 +32,7 @@ tconsOf (ForallType _ te) = tconsOf te
-----------------------------------------------------------------------------
-- list of direct dependencies for a function
callsDirectly :: FuncDecl -> [QName]
callsDirectly fun = setRBT2list (snd (directlyDependent fun))
callsDirectly fun = toList (snd (directlyDependent fun))
-- set of direct dependencies for a function
directlyDependent :: FuncDecl -> (QName,SetRBT QName)
......@@ -45,12 +46,12 @@ funcSetOfExpr (Var _) = emptySet
funcSetOfExpr (Lit _) = emptySet
funcSetOfExpr (Comb ct f es) =
if isConstructorComb ct then unionMap funcSetOfExpr es
else insertRBT f (unionMap funcSetOfExpr es)
else insert f (unionMap funcSetOfExpr es)
funcSetOfExpr (Free _ e) = funcSetOfExpr e
funcSetOfExpr (Let bs e) = unionRBT (unionMap (funcSetOfExpr . snd) bs)
funcSetOfExpr (Let bs e) = union (unionMap (funcSetOfExpr . snd) bs)
(funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = unionRBT (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = union (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = union (funcSetOfExpr e)
(unionMap funcSetOfBranch bs)
where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
funcSetOfExpr (Typed e _) = funcSetOfExpr e
......@@ -62,10 +63,10 @@ isConstructorComb ct = case ct of
_ -> False
unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f
unionMap f = foldr union emptySet . map f
emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName
emptySet = empty leqQName
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2)
......@@ -3,7 +3,7 @@
--- In particular, it contains some simple fixpoint computations.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version September 2018
--- @version December 2018
--------------------------------------------------------------------------
module CASS.WorkerFunctions where
......@@ -12,7 +12,6 @@ import FiniteMap
import IOExts
import List ( partition )
import Maybe ( fromJust )
import SetRBT
import System ( getCPUTime )
import Analysis.Files
......@@ -26,6 +25,7 @@ import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import Data.SCC ( scc )
import Data.Set.RBTree as Set ( SetRBT, member, empty, insert, null )
import CASS.Configuration
import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes )
......@@ -193,17 +193,17 @@ runAnalysis analysis prog importInfos startvals fpmethod = do
SimpleTypeAnalysis _ _ ->
(definedTypes, typeInfos2ProgInfo defaultTypes deflts)
SimpleConstructorAnalysis _ _ -> -- there are no external constructors
if null deflts then (prog,emptyProgInfo)
if Prelude.null deflts then (prog,emptyProgInfo)
else error "SimpleConstructorAnalysis with default values!"
DependencyFuncAnalysis _ _ _ ->
(definedFuncs, funcInfos2ProgInfo defaultFuncs deflts)
DependencyTypeAnalysis _ _ _ ->
(definedTypes, typeInfos2ProgInfo defaultTypes deflts)
SimpleModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo)
if Prelude.null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError
DependencyModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo)
if Prelude.null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError
_ -> error "Internal error in WorkerFunctions.runAnalysis"
let result = executeAnalysis analysis progWithoutDefaults
......@@ -260,7 +260,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
"wlist" ->
let declsWithDeps = map addCalledFunctions (progFuncs prog)
in funcInfos2ProgInfo prog $ fmToList $
wlIteration anaFunc funcName declsWithDeps [] (emptySetRBT (<))
wlIteration anaFunc funcName declsWithDeps [] (empty (<))
importInfos (listToFM (<) startvals)
"wlistscc" ->
let declsWithDeps = map addCalledFunctions (progFuncs prog)
......@@ -268,7 +268,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps
in funcInfos2ProgInfo prog $ fmToList $
foldr (\scc sccstartvals ->
wlIteration anaFunc funcName scc [] (emptySetRBT (<))
wlIteration anaFunc funcName scc [] (empty (<))
importInfos sccstartvals)
(listToFM (<) startvals)
(reverse sccDecls)
......@@ -284,7 +284,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
"wlist" ->
let declsWithDeps = map addUsedTypes (progTypes prog)
in typeInfos2ProgInfo prog $ fmToList $
wlIteration anaType typeName declsWithDeps [] (emptySetRBT (<))
wlIteration anaType typeName declsWithDeps [] (empty (<))
importInfos (listToFM (<) startvals)
"wlistscc" ->
let declsWithDeps = map addUsedTypes (progTypes prog)
......@@ -292,7 +292,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps
in typeInfos2ProgInfo prog $ fmToList $
foldr (\scc sccstartvals ->
wlIteration anaType typeName scc [] (emptySetRBT (<))
wlIteration anaType typeName scc [] (empty (<))
importInfos sccstartvals)
(listToFM (<) startvals)
(reverse sccDecls)
......@@ -359,13 +359,13 @@ wlIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
-- importInfos currvals
wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals =
if isEmptySetRBT changedEntities
if Set.null changedEntities
then currvals -- no todos, no changed values, so we are done:
else -- all declarations processed, compute todos for next round:
let (declsToDo,declsDone) =
partition (\ (_,calls) -> any (`elemRBT` changedEntities) calls)
partition (\ (_,calls) -> any (`member` changedEntities) calls)
alldecls
in wlIteration analysis nameOf declsToDo declsDone (emptySetRBT (<))
in wlIteration analysis nameOf declsToDo declsDone (empty (<))
importInfos currvals
-- process a single declaration:
wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone
......@@ -380,7 +380,7 @@ wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone
then wlIteration analysis nameOf decls (decldeps:declsDone)
changedEntities importInfos currvals
else wlIteration analysis nameOf decls (decldeps:declsDone)
(insertRBT decname changedEntities) importInfos
(insert decname changedEntities) importInfos
(updFM currvals decname (const newval))
......
......@@ -10,6 +10,7 @@
"base" : ">= 1.0.0, < 2.0.0",
"currypath" : ">= 0.0.1",
"frontend-exec" : ">= 0.0.1",
"redblacktree" : ">= 0.0.1",
"wl-pprint" : ">= 0.0.1",
"xml" : ">= 2.0.0"
},
......
......@@ -14,19 +14,20 @@ module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry,
Option(..),RequiredSpec,requires,alwaysRequired,
defaultRequired) where
import FlatCurry.Types
import FlatCurry.Files
import SetRBT
import TableRBT
import Maybe
import List ( nub, union )
import Directory
import FileGoodies
import FilePath ( takeFileName, (</>) )
import Directory
import List ( nub, union )
import Maybe
import Sort ( cmpString, leqString )
import XML
import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix )
import Data.Set.RBTree as Set ( SetRBT, member, empty, insert )
import Data.Table.RBTree as Table ( TableRBT, empty, lookup, update )
import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix )
import FlatCurry.Types
import FlatCurry.Files
infix 0 `requires`
......@@ -180,7 +181,7 @@ computeCompactFlatCurry orgoptions progname =
makeCompactFlatCurry :: Prog -> [Option] -> IO Prog
makeCompactFlatCurry mainmod options = do
(initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options
let initFuncTable = extendFuncTable (emptyTableRBT leqQName)
let initFuncTable = extendFuncTable (Table.empty leqQName)
(concatMap moduleFuns loadedmods)
required = getRequiredFromOptions options
loadedreqfuns = concatMap (getRequiredInModule required)
......@@ -189,8 +190,8 @@ makeCompactFlatCurry mainmod options = do
(finalmods,finalfuncs,finalcons,finaltcons) <-
getCalledFuncs required
loadedmnames loadedmods initFuncTable
(foldr insertRBT (emptySetRBT leqQName) initreqfuncs)
(emptySetRBT leqQName) (emptySetRBT leqQName)
(foldr insert (Set.empty leqQName) initreqfuncs)
(Set.empty leqQName) (Set.empty leqQName)
initreqfuncs
putStrLn ("\nCompactFlat: Total number of functions (without unused imports): "
++ show (foldr (+) 0 (map (length . moduleFuns) finalmods)))
......@@ -201,7 +202,7 @@ makeCompactFlatCurry mainmod options = do
reqTCons = extendTConsWithConsType finalcons finaltcons
allTDecls
allReqTCons = requiredDatatypes reqTCons allTDecls
in filter (\tdecl->tconsName tdecl `elemRBT` allReqTCons)
in filter (\tdecl->tconsName tdecl `member` allReqTCons)
allTDecls)
finalfuncs
(filter (\ (Op oname _ _) -> oname `elem` finalfnames)
......@@ -215,18 +216,18 @@ requiredDatatypes tcnames tdecls =
let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
in if null newtcons
then tcnames
else requiredDatatypes (foldr insertRBT tcnames newtcons) tdecls
else requiredDatatypes (foldr insert tcnames newtcons) tdecls
-- Extract the new type constructors (w.r.t. a given set) contained in a
-- type declaration:
newTypeConsOfTDecl :: SetRBT QName -> TypeDecl -> [QName]
newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
if tcons `elemRBT` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames)) (allTypesOfTExpr texp)
if tcons `member` tcnames
then filter (\tc -> not (tc `member` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
if tcons `elemRBT` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames))
if tcons `member` tcnames
then filter (\tc -> not (tc `member` tcnames))
(concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps)
cdecls)
else []
......@@ -237,11 +238,11 @@ extendTConsWithConsType :: SetRBT QName -> SetRBT QName -> [TypeDecl]
-> SetRBT QName
extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
extendTConsWithConsType cnames (insertRBT tname tcons) tds
extendTConsWithConsType cnames (insert tname tcons) tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
if tname `elem` defaultRequiredTypes ||
any (\cdecl->consName cdecl `elemRBT` cnames) cdecls
then extendTConsWithConsType cnames (insertRBT tname tcons) tds
any (\cdecl->consName cdecl `member` cnames) cdecls
then extendTConsWithConsType cnames (insert tname tcons) tds
else extendTConsWithConsType cnames tcons tds
-- Extend function table (mapping from qualified names to function declarations)
......@@ -249,7 +250,7 @@ extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl]
-> TableRBT QName FuncDecl
extendFuncTable ftable fdecls =
foldr (\f t -> updateRBT (functionName f) f t) ftable fdecls
foldr (\f t -> update (functionName f) f t) ftable fdecls
-------------------------------------------------------------------------------
......@@ -289,9 +290,9 @@ requiredInCompactProg mainmod options
mainexports = exportedFuncNames (moduleFuns mainmod)
mainmodset = insertRBT mainmodname (emptySetRBT leqString)
mainmodset = insert mainmodname (Set.empty leqString)
add2mainmodset mnames = foldr insertRBT mainmodset mnames
add2mainmodset mnames = foldr insert mainmodset mnames
-- extract the names of all exported functions:
......@@ -321,30 +322,30 @@ getCalledFuncs :: [RequiredSpec] -> SetRBT String -> [Prog]
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
loadedtnames ((m,f):fs)
| not (elemRBT m loadedmnames)
| not (member m loadedmnames)
= do newmod <- readCurrentFlatCurry m
let reqnewfun = getRequiredInModule required m
getCalledFuncs required (insertRBT m loadedmnames) (newmod:progs)
getCalledFuncs required (insert m loadedmnames) (newmod:progs)
(extendFuncTable functable (moduleFuns newmod))
(foldr insertRBT loadedfnames reqnewfun) loadedcnames
(foldr insert loadedfnames reqnewfun) loadedcnames
loadedtnames ((m,f):fs ++ reqnewfun)
| isNothing (lookupRBT (m,f) functable)
| isNothing (Table.lookup (m,f) functable)
= -- this must be a data constructor: ingore it since already considered
getCalledFuncs required loadedmnames progs
functable loadedfnames loadedcnames loadedtnames fs
| otherwise = do
let fdecl = fromJust (lookupRBT (m,f) functable)
let fdecl = fromJust (Table.lookup (m,f) functable)
funcCalls = allFuncCalls fdecl
newFuncCalls = filter (\qn->not (elemRBT qn loadedfnames)) funcCalls
newFuncCalls = filter (\qn->not (member qn loadedfnames)) funcCalls
newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
consCalls = allConstructorsOfFunc fdecl
newConsCalls = filter (\qn->not (elemRBT qn loadedcnames)) consCalls
newConsCalls = filter (\qn->not (member qn loadedcnames)) consCalls
newtcons = allTypesOfFunc fdecl
(newprogs,newfuns,newcons, newtypes) <-
getCalledFuncs required loadedmnames progs functable
(foldr insertRBT loadedfnames (newFuncCalls++newReqs))
(foldr insertRBT loadedcnames consCalls)
(foldr insertRBT loadedtnames newtcons)
(foldr insert loadedfnames (newFuncCalls++newReqs))
(foldr insert loadedcnames consCalls)
(foldr insert loadedtnames newtcons)
(fs ++ newFuncCalls ++ newReqs ++ newConsCalls)
return (newprogs, fdecl:newfuns, newcons, newtypes)
......@@ -525,7 +526,7 @@ mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl]
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
let fname = lookup name trans in
let fname = Prelude.lookup name trans in
if fname==Nothing
then [Func name ar vis tp rule]
else let Just (lib,entry) = fname
......
Copyright (c) 2018, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the names of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
random
======
This package contains the library `System.Random`
for pseudo-random number generation in Curry.
{
"name": "random",
"version": "0.0.1",
"author": "Sergio Antoy <antoy@cs.pdx.edu>",
"maintainer": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Library for pseudo-random number generation",
"category": [ "Programming", "Numeric" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0",
"kics2": ">= 2.0.0"
},
"exportedModules": [ "System.Random" ],
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/random.git",
"tag": "$version"
}
}
------------------------------------------------------------------------------
--- Library for pseudo-random number generation in Curry.
---
--- This library provides operations for generating pseudo-random
--- number sequences.
--- For any given seed, the sequences generated by the operations
--- in this module should be **identical** to the sequences
--- generated by the `java.util.Random package`.
---
------------------------------------------------------------------------------
--- The KiCS2 implementation is based on an algorithm taken from
--- <http://en.wikipedia.org/wiki/Random_number_generation>.
--- There is an assumption that all operations are implicitly
--- executed mod 2^32 (unsigned 32-bit integers) !!!
--- GHC computes between -2^29 and 2^29-1, thus the sequence
--- is NOT as random as one would like.
---
--- m_w = <choose-initializer>; /* must not be zero */
--- m_z = <choose-initializer>; /* must not be zero */
---
--- uint get_random()
--- {
--- m_z = 36969 * (m_z & 65535) + (m_z >> 16);
--- m_w = 18000 * (m_w & 65535) + (m_w >> 16);
--- return (m_z << 16) + m_w; /* 32-bit result */
--- }
---
------------------------------------------------------------------------------
--- The PAKCS implementation is a linear congruential pseudo-random number
--- generator described in
--- Donald E. Knuth, _The Art of Computer Programming_,
--- Volume 2: _Seminumerical Algorithms_, section 3.2.1.
---
------------------------------------------------------------------------------
--- @author Sergio Antoy (with extensions by Michael Hanus)
--- @version June 2017
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module System.Random
( nextInt, nextIntRange, nextBoolean, getRandomSeed
, shuffle
) where
import System ( getCPUTime )
import Time ( CalendarTime(..), getClockTime, toUTCTime )
#ifdef __PAKCS__
------------------------------------------------------------------
-- Private Operations
------------------------------------------------------------------
-- a few constants
multiplier :: Int
multiplier = 25214903917
addend :: Int
addend = 11
powermask :: Int
powermask = 48
mask :: Int
mask = 281474976710656 -- 2^powermask
intsize :: Int
intsize = 32
intspan :: Int
intspan = 4294967296 -- 2^intsize
intlimit :: Int
intlimit = 2147483648 -- 2^(intsize-1)
-- the basic sequence of random values
sequence :: Int -> [Int]
sequence seed = next : sequence next
where next = nextseed seed
-- auxiliary private operations
nextseed :: Int -> Int
nextseed seed = (seed * multiplier + addend) `rem` mask
xor :: Int -> Int -> Int
xor x y = if (x==0) && (y==0) then 0 else lastBit + 2 * restBits
where lastBit = if (x `rem` 2) == (y `rem` 2) then 0 else 1
restBits = xor (x `quot` 2) (y `quot` 2)
power :: Int -> Int -> Int
power base exp = binary 1 base exp
where binary x b e
= if (e == 0) then x
else binary (x * if (e `rem` 2 == 1) then b else 1)
(b * b)
(e `quot` 2)
nextIntBits :: Int -> Int -> [Int]
nextIntBits seed bits = map adjust list
where init = (xor seed multiplier) `rem` mask
list = sequence init
shift = power 2 (powermask - bits)
adjust x = if arg > intlimit then arg - intspan
else arg
where arg = (x `quot` shift) `rem` intspan
#else
zfact :: Int
zfact = 36969
wfact :: Int
wfact = 18000
two16 :: Int
two16 = 65536
large :: Int
large = 536870911 -- 2^29 - 1
#endif
------------------------------------------------------------------
-- Public Operations
------------------------------------------------------------------
--- Returns a sequence of pseudorandom, integer values.
---
--- @param seed - The seed of the random sequence.
nextInt :: Int -> [Int]
#ifdef __PAKCS__
nextInt seed = nextIntBits seed intsize
#else
nextInt seed =
let ns = if seed == 0 then 1 else seed
next2 mw mz =
let mza = zfact * (mz `mod` two16) + (mz * two16)
mwa = wfact * (mw `mod` two16) + (mw * two16)
tmp = (mza `div` two16 + mwa)
res = if tmp < 0 then tmp+large else tmp
in res : next2 mwa mza
in next2 ns ns
#endif
--- Returns a pseudorandom sequence of values
--- between 0 (inclusive) and the specified value (exclusive).
---
--- @param seed - The seed of the random sequence.
--- @param n - The bound on the random number to be returned.
--- Must be positive.
nextIntRange :: Int -> Int -> [Int]
#ifdef __PAKCS__
nextIntRange seed n | n>0
= if power_of_2 n then map adjust_a seq
else map adjust_b (filter adjust_c seq)
where seq = nextIntBits seed (intsize - 1)
adjust_a x = (n * x) `quot` intlimit
adjust_b x = x `rem` n
adjust_c x = x - (x `rem` n) + (n - 1) >= 0
power_of_2 k = k == 2 ||
k > 2 && k `rem` 2 == 0 && power_of_2 (k `quot` 2)
#else
nextIntRange seed n | n>0
= map (`mod` n) (nextInt seed)
#endif
--- Returns a pseudorandom sequence of boolean values.
---