├── .github └── workflows │ ├── haskell-ci.yml │ └── simple.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CONTRIBUTING.md ├── Changelog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── bench ├── Bench.hs ├── Range.hs └── SimpleSum.hs ├── cabal.haskell-ci ├── cabal.project ├── cbits-unix └── init.c ├── cbits-win └── init.c ├── make-hugs.sh ├── simple-sum.sh ├── splitmix.cabal ├── src-compat └── Data │ └── Bits │ └── Compat.hs ├── src └── System │ └── Random │ ├── SplitMix.hs │ ├── SplitMix │ └── Init.hs │ └── SplitMix32.hs ├── test-hugs.sh ├── tests ├── Dieharder.hs ├── Examples.hs ├── Initialization.hs ├── MiniQC.hs ├── SplitMixPi.hs ├── SplitMixPi32.hs ├── TestU01.hs ├── Tests.hs ├── Uniformity.hs └── cbits │ └── testu01.c └── tools ├── LICENSE ├── splitmix-tools.cabal └── src ├── Avalanche.hs ├── Dummy.hs ├── GenMix32.hs └── SimulatedAnnealing.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241220 12 | # 13 | # REGENDATA ("0.19.20241220",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-20.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.1 36 | compilerKind: ghc 37 | compilerVersion: 9.12.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.1 41 | compilerKind: ghc 42 | compilerVersion: 9.10.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.6 51 | compilerKind: ghc 52 | compilerVersion: 9.6.6 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.4 71 | compilerKind: ghc 72 | compilerVersion: 8.10.4 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | fail-fast: false 86 | steps: 87 | - name: apt-get install 88 | run: | 89 | apt-get update 90 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 91 | apt-get install -y hugs libhugs-time-bundled libtestu01-0-dev 92 | - name: Install GHCup 93 | run: | 94 | mkdir -p "$HOME/.ghcup/bin" 95 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 96 | chmod a+x "$HOME/.ghcup/bin/ghcup" 97 | - name: Install cabal-install (prerelease) 98 | run: | 99 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 100 | "$HOME/.ghcup/bin/ghcup" install cabal 3.15.0.0.2024.10.3 || (cat "$HOME"/.ghcup/logs/*.* && false) 101 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.15.0.0.2024.10.3 -vnormal+nowrap" >> "$GITHUB_ENV" 102 | - name: Install GHC (GHCup) 103 | if: matrix.setup-method == 'ghcup' 104 | run: | 105 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 106 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 107 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 108 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 109 | echo "HC=$HC" >> "$GITHUB_ENV" 110 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 111 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 112 | env: 113 | HCKIND: ${{ matrix.compilerKind }} 114 | HCNAME: ${{ matrix.compiler }} 115 | HCVER: ${{ matrix.compilerVersion }} 116 | - name: Set PATH and environment variables 117 | run: | 118 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 119 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 120 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 121 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 122 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 123 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 124 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 125 | echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" 126 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 127 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 128 | env: 129 | HCKIND: ${{ matrix.compilerKind }} 130 | HCNAME: ${{ matrix.compiler }} 131 | HCVER: ${{ matrix.compilerVersion }} 132 | - name: env 133 | run: | 134 | env 135 | - name: write cabal config 136 | run: | 137 | mkdir -p $CABAL_DIR 138 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 171 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 172 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 173 | rm -f cabal-plan.xz 174 | chmod a+x $HOME/.cabal/bin/cabal-plan 175 | cabal-plan --version 176 | - name: install cabal-docspec 177 | run: | 178 | mkdir -p $HOME/.cabal/bin 179 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 180 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 181 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 182 | rm -f cabal-docspec.xz 183 | chmod a+x $HOME/.cabal/bin/cabal-docspec 184 | cabal-docspec --version 185 | - name: checkout 186 | uses: actions/checkout@v4 187 | with: 188 | path: source 189 | - name: initial cabal.project for sdist 190 | run: | 191 | touch cabal.project 192 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 193 | cat cabal.project 194 | - name: sdist 195 | run: | 196 | mkdir -p sdist 197 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 198 | - name: unpack 199 | run: | 200 | mkdir -p unpacked 201 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 202 | - name: generate cabal.project 203 | run: | 204 | PKGDIR_splitmix="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/splitmix-[0-9.]*')" 205 | echo "PKGDIR_splitmix=${PKGDIR_splitmix}" >> "$GITHUB_ENV" 206 | rm -f cabal.project cabal.project.local 207 | touch cabal.project 208 | touch cabal.project.local 209 | echo "packages: ${PKGDIR_splitmix}" >> cabal.project 210 | echo "package splitmix" >> cabal.project 211 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 212 | cat >> cabal.project <> cabal.project.local 218 | cat cabal.project 219 | cat cabal.project.local 220 | - name: dump install plan 221 | run: | 222 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 223 | cabal-plan 224 | - name: restore cache 225 | uses: actions/cache/restore@v4 226 | with: 227 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 228 | path: ~/.cabal/store 229 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 230 | - name: install dependencies 231 | run: | 232 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 233 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 234 | - name: build w/o tests 235 | run: | 236 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 237 | - name: build 238 | run: | 239 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 240 | - name: tests 241 | run: | 242 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 243 | - name: docspec 244 | run: | 245 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 246 | cabal-docspec $ARG_COMPILER 247 | - name: cabal check 248 | run: | 249 | cd ${PKGDIR_splitmix} || false 250 | ${CABAL} -vnormal check 251 | - name: haddock 252 | run: | 253 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 254 | - name: unconstrained build 255 | run: | 256 | rm -f cabal.project.local 257 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 258 | - name: prepare for constraint sets 259 | run: | 260 | rm -f cabal.project.local 261 | - name: constraint set bytestring-0.12 262 | run: | 263 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.12' all --dry-run 264 | cabal-plan topo | sort 265 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.12' --dependencies-only -j2 all 266 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.12' all 267 | $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.12' all 268 | - name: constraint set bytestring-0.11 269 | run: | 270 | if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.11' all --dry-run ; fi 271 | if [ $((HCNUMVER < 90800)) -ne 0 ] ; then cabal-plan topo | sort ; fi 272 | if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.11' --dependencies-only -j2 all ; fi 273 | if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.11' all ; fi 274 | if [ $((HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>=0.11' all ; fi 275 | - name: constraint set time-1.12 276 | run: | 277 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 91200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='time ^>=1.12' all --dry-run ; fi 278 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 91200)) -ne 0 ] ; then cabal-plan topo | sort ; fi 279 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 91200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='time ^>=1.12' --dependencies-only -j2 all ; fi 280 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 91200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='time ^>=1.12' all ; fi 281 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 91200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='time ^>=1.12' all ; fi 282 | - name: constraint set time-1.11 283 | run: | 284 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.11' all --dry-run ; fi 285 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then cabal-plan topo | sort ; fi 286 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.11' --dependencies-only -j2 all ; fi 287 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.11' all ; fi 288 | - name: constraint set time-1.10 289 | run: | 290 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.10' all --dry-run ; fi 291 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then cabal-plan topo | sort ; fi 292 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.10' --dependencies-only -j2 all ; fi 293 | if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='time ^>=1.10' all ; fi 294 | - name: save cache 295 | if: always() 296 | uses: actions/cache/save@v4 297 | with: 298 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 299 | path: ~/.cabal/store 300 | -------------------------------------------------------------------------------- /.github/workflows/simple.yml: -------------------------------------------------------------------------------- 1 | name: Simple 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | branches: 8 | - master 9 | 10 | jobs: 11 | native: 12 | name: "Simple: GHC ${{ matrix.ghc }} on ${{ matrix.os }}" 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | matrix: 16 | os: [macos-latest, windows-latest] 17 | ghc: ['8.10','9.0','9.2','9.4'] 18 | fail-fast: false 19 | steps: 20 | - name: Set git to use LF 21 | run: | 22 | git config --global core.autocrlf false 23 | git config --global core.eol lf 24 | 25 | - name: Checkout 26 | uses: actions/checkout@v3.0.2 27 | 28 | - name: Set up Haskell 29 | id: setup-haskell 30 | uses: haskell/actions/setup@v2 31 | with: 32 | ghc-version: ${{ matrix.ghc }} 33 | cabal-version: '3.10.1.0' 34 | 35 | - name: Cache 36 | uses: actions/cache@v2.1.3 37 | with: 38 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 39 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }} 40 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 41 | 42 | - name: Build 43 | run: cabal build all --enable-tests 44 | 45 | - name: Test 46 | run: cabal test all --enable-tests --test-show-details=direct 47 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .ghc.environment.* 4 | cabal.project.local 5 | .stack-work 6 | bench.html 7 | splitmix-hugs 8 | hugs.output 9 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: group 4 | list_align: after_alias 5 | long_list_align: new_line 6 | empty_list_align: right_after 7 | list_padding: module_name 8 | - language_pragmas: 9 | style: vertical 10 | remove_redundant: true 11 | - trailing_whitespace: {} 12 | columns: 80 13 | language_extensions: 14 | - DataKinds 15 | - EmptyCase 16 | - ExplicitForAll 17 | - FlexibleContexts 18 | - MultiParamTypeClasses 19 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Patches welcome! 2 | 3 | - If you are only going to bump bounds: 4 | - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it. 5 | - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**: 6 | - Amend `tested-with` to include that GHC 7 | - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci)) 8 | 9 | - Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts. 10 | - For the same reason, do not edit `version` or `x-revision` 11 | 12 | - I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing. 13 | - General code style is 4 spaces, just look around how it looks, it's not so strict. 14 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # 0.1.1 2 | 3 | - Drop support for GHCs prior 8.6.5 4 | - Support GHC-9.12 5 | 6 | # 0.1.0.4 7 | 8 | - Add TestU01 test-suite 9 | 10 | # 0.1.0.3 11 | 12 | - Fix oops bugs in 0.1.0.2 13 | 14 | - It's lowercase `windows.h`. 15 | I blame Microsoft docs for using capital case `Windows.h` in the docs. 16 | https://docs.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-getprocessid 17 | 18 | - accidental `shiftL` vs `shiftR` mixup for 32-bit generator initialization. 19 | Doesn't affect Linux. 20 | 21 | # 0.1.0.2 22 | 23 | - Drop `time` dependency in favour of handcoded initialization 24 | - On Unix platforms we use `/dev/urandom` if it exists, 25 | otherwise use `gettimeofday`, `clock` and `getpid`. 26 | - On Windows we use `GetCurrentProcessID`, `GetCurrentThreadId()`, 27 | `GetTickCount`, `GetSystemTime` and `QueryPerformanceCounter`. 28 | - On GHCJS use `Math.random()` 29 | - Using `time` is a fallback option (e.g. for Hugs). 30 | 31 | # 0.1.0.1 32 | 33 | - Add `INLINEABLE` pragmas to `bitmaskWithRejection*` functions 34 | - Support GHC-9.0 35 | 36 | # 0.1 37 | 38 | - Drop `random` dependency unconditionally. 39 | https://github.com/phadej/splitmix/issues/34 40 | 41 | # 0.0.5 42 | 43 | - Add `nextInteger` 44 | - Use smaller range in `bitmaskWithRejection32` and `64`, 45 | when upper bound is 2^n - 1. 46 | This changes generated values when they were on the boundary. 47 | 48 | # 0.0.4 49 | 50 | - Add `bitmaskWithRejection32'` and `bitmaskWithRejection64'` 51 | which generate numbers in closed range `[0, n]`. 52 | Unticked variants generate in closed-open range `[0, n)`. 53 | 54 | # 0.0.3 55 | 56 | - Add `System.Random.SplitMix32` module 57 | - Add `bitmaskWithRejection32` and `bitmaskWithRejection64` functions 58 | - Add `nextWord32`, `nextTwoWord32` and `nextFloat` 59 | - Add `random` flag, dropping dependency on `random` 60 | (breaks things, e.g. `QuickCheck`, when disabled). 61 | 62 | # 0.0.2 63 | 64 | - Support back to GHC-7.0 65 | - Add `Read SMGen` instance 66 | 67 | # 0.0.1 68 | 69 | - Add `NFData SMGen` instance 70 | - Fix a bug. http://www.pcg-random.org/posts/bugs-in-splitmix.html 71 | The generated numbers will be different for the same seeds! 72 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Oleg Grenrus 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Oleg Grenrus nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all : build 2 | 3 | build : 4 | cabal v2-build 5 | 6 | build-ghcjs : 7 | cabal v2-build -w /opt/ghcjs/8.4/bin/ghcjs --ghcjs 8 | 9 | montecarlo-pi-time : 10 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.0.4 > /dev/null 11 | time $$(cabal-plan list-bin montecarlo-pi) 12 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.2.2 > /dev/null 13 | time $$(cabal-plan list-bin montecarlo-pi) 14 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.4.2 > /dev/null 15 | time $$(cabal-plan list-bin montecarlo-pi) 16 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.6.3 > /dev/null 17 | time $$(cabal-plan list-bin montecarlo-pi) 18 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.8.4 > /dev/null 19 | time $$(cabal-plan list-bin montecarlo-pi) 20 | cabal v2-build montecarlo-pi --enable-tests -w ghc-7.10.3 > /dev/null 21 | time $$(cabal-plan list-bin montecarlo-pi) 22 | cabal v2-build montecarlo-pi --enable-tests -w ghc-8.0.2 > /dev/null 23 | time $$(cabal-plan list-bin montecarlo-pi) 24 | cabal v2-build montecarlo-pi --enable-tests -w ghc-8.2.2 > /dev/null 25 | time $$(cabal-plan list-bin montecarlo-pi) 26 | cabal v2-build montecarlo-pi --enable-tests -w ghc-8.4.4 > /dev/null 27 | time $$(cabal-plan list-bin montecarlo-pi) 28 | cabal v2-build montecarlo-pi --enable-tests -w ghc-8.6.5 > /dev/null 29 | time $$(cabal-plan list-bin montecarlo-pi) 30 | 31 | generate-mix32 : 32 | cabal v2-build generate-mix32 && $$(cabal-plan list-bin generate-mix32) 33 | 34 | doctest : 35 | perl -i -e 'while () { print unless /package-id base-compat-\d+(\.\d+)*/; }' .ghc.environment.* 36 | doctest src 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # splitmix 2 | 3 | Pure Haskell implementation of SplitMix pseudo-random number generator. 4 | 5 | ## dieharder 6 | 7 | > [Dieharder](http://webhome.phy.duke.edu/~rgb/General/dieharder.php) is a random 8 | number generator (rng) testing suite. It is intended to test generators, not 9 | files of possibly random numbers as the latter is a fallacious view of what it 10 | means to be random. Is the number 7 random? If it is generated by a random 11 | process, it might be. If it is made up to serve the purpose of some argument 12 | (like this one) it is not. Perfect random number generators produce "unlikely" 13 | sequences of random numbers – at exactly the right average rate. Testing a rng 14 | is therefore quite subtle. 15 | 16 | ``` 17 | time $(cabal-plan list-bin splitmix-dieharder) splitmix 18 | ``` 19 | 20 | The test-suite takes around half-an-hour to complete. 21 | From 30 runs, 2.49% were weak (3247 passed, 83 weak, 0 failed). 22 | 23 | In comparison, built-in [Marsenne Twister](https://en.wikipedia.org/wiki/Mersenne_Twister) 24 | test takes around 15min. 25 | 26 | ``` 27 | time dieharder -a 28 | ``` 29 | 30 | ## benchmarks 31 | 32 | ``` 33 | benchmarking list 64/random 34 | time 1.317 ms (1.303 ms .. 1.335 ms) 35 | 0.998 R² (0.998 R² .. 0.999 R²) 36 | mean 1.380 ms (1.365 ms .. 1.411 ms) 37 | std dev 70.83 μs (37.26 μs .. 131.8 μs) 38 | variance introduced by outliers: 39% (moderately inflated) 39 | 40 | benchmarking list 64/tf-random 41 | time 141.1 μs (140.4 μs .. 142.1 μs) 42 | 0.999 R² (0.998 R² .. 1.000 R²) 43 | mean 145.9 μs (144.6 μs .. 150.4 μs) 44 | std dev 7.131 μs (3.461 μs .. 14.75 μs) 45 | variance introduced by outliers: 49% (moderately inflated) 46 | 47 | benchmarking list 64/splitmix 48 | time 17.86 μs (17.72 μs .. 18.01 μs) 49 | 0.999 R² (0.998 R² .. 1.000 R²) 50 | mean 17.95 μs (17.75 μs .. 18.47 μs) 51 | std dev 1.000 μs (444.1 ns .. 1.887 μs) 52 | variance introduced by outliers: 64% (severely inflated) 53 | 54 | benchmarking tree 64/random 55 | time 800.3 μs (793.3 μs .. 806.5 μs) 56 | 0.999 R² (0.998 R² .. 0.999 R²) 57 | mean 803.2 μs (798.1 μs .. 811.2 μs) 58 | std dev 22.09 μs (14.69 μs .. 35.47 μs) 59 | variance introduced by outliers: 18% (moderately inflated) 60 | 61 | benchmarking tree 64/tf-random 62 | time 179.0 μs (176.6 μs .. 180.7 μs) 63 | 0.999 R² (0.998 R² .. 0.999 R²) 64 | mean 172.7 μs (171.3 μs .. 174.6 μs) 65 | std dev 5.590 μs (4.919 μs .. 6.382 μs) 66 | variance introduced by outliers: 29% (moderately inflated) 67 | 68 | benchmarking tree 64/splitmix 69 | time 51.54 μs (51.01 μs .. 52.15 μs) 70 | 0.999 R² (0.998 R² .. 0.999 R²) 71 | mean 52.50 μs (51.93 μs .. 53.55 μs) 72 | std dev 2.603 μs (1.659 μs .. 4.338 μs) 73 | variance introduced by outliers: 55% (severely inflated) 74 | ``` 75 | 76 | Note: the performance can be potentially further improved when GHC gets 77 | [SIMD Support](https://ghc.haskell.org/trac/ghc/wiki/SIMD/Implementation/Status). 78 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Criterion.Main 4 | import Data.List (unfoldr) 5 | import Data.Word (Word64) 6 | 7 | import qualified Data.Tree as T 8 | import qualified System.Random as R 9 | import qualified System.Random.TF as TF 10 | import qualified System.Random.TF.Instances as TF 11 | import qualified System.Random.SplitMix as SM 12 | import qualified System.Random.SplitMix32 as SM32 13 | 14 | ------------------------------------------------------------------------------- 15 | -- List 16 | ------------------------------------------------------------------------------- 17 | 18 | -- infinite list 19 | genList :: (g -> (Int, g)) -> g -> [Int] 20 | genList next = unfoldr (Just . next) 21 | 22 | -- truncated 23 | genListN :: (g -> (Int, g)) -> g -> [Int] 24 | genListN next = take 2048 . genList next 25 | 26 | randomList :: Int -> [Int] 27 | randomList = genListN R.random . R.mkStdGen 28 | 29 | tfRandomList :: Word64 -> [Int] 30 | tfRandomList w64 = genListN R.random $ TF.seedTFGen (w64, w64, w64, w64) 31 | 32 | splitMixList :: Word64 -> [Int] 33 | splitMixList w64 = genListN SM.nextInt $ SM.mkSMGen w64 34 | 35 | splitMix32List :: Word64 -> [Int] 36 | splitMix32List w64 = genListN SM32.nextInt $ SM32.mkSMGen $ fromIntegral w64 37 | 38 | ------------------------------------------------------------------------------- 39 | -- Tree 40 | ------------------------------------------------------------------------------- 41 | 42 | genTree :: (g -> (Int, g)) -> (g -> (g, g)) -> g -> T.Tree Int 43 | genTree next split = go where 44 | go g = case next g of 45 | ~(i, g') -> T.Node i $ case split g' of 46 | (ga, gb) -> [go ga, go gb] 47 | 48 | genTreeN :: (g -> (Int, g)) -> (g -> (g, g)) -> g -> T.Tree Int 49 | genTreeN next split = cutTree 9 . genTree next split 50 | where 51 | cutTree :: Int -> T.Tree a -> T.Tree a 52 | cutTree n (T.Node x forest) 53 | | n <= 0 = T.Node x [] 54 | | otherwise = T.Node x (map (cutTree (n - 1)) forest) 55 | 56 | randomTree :: Int -> T.Tree Int 57 | randomTree = genTreeN R.next R.split . R.mkStdGen 58 | 59 | tfRandomTree :: Word64 -> T.Tree Int 60 | tfRandomTree w64 = genTreeN R.next R.split $ TF.seedTFGen (w64, w64, w64, w64) 61 | 62 | splitMixTree :: Word64 -> T.Tree Int 63 | splitMixTree w64 = genTreeN SM.nextInt SM.splitSMGen $ SM.mkSMGen w64 64 | 65 | splitMix32Tree :: Word64 -> T.Tree Int 66 | splitMix32Tree w64 = genTreeN SM32.nextInt SM32.splitSMGen $ SM32.mkSMGen $ fromIntegral w64 67 | 68 | ------------------------------------------------------------------------------- 69 | -- List Word64 70 | ------------------------------------------------------------------------------- 71 | 72 | -- infinite list 73 | genList64 :: (g -> (Word64, g)) -> g -> [Word64] 74 | genList64 r = unfoldr (Just . r) 75 | 76 | -- truncated 77 | genListN64 :: (g -> (Word64, g)) -> g -> [Word64] 78 | genListN64 r = take 2048 . genList64 r 79 | 80 | randomList64 :: Int -> [Word64] 81 | randomList64 = genListN64 R.random . R.mkStdGen 82 | 83 | tfRandomList64 :: Word64 -> [Word64] 84 | tfRandomList64 w64 = genListN64 TF.random $ TF.seedTFGen (w64, w64, w64, w64) 85 | 86 | splitMixList64 :: Word64 -> [Word64] 87 | splitMixList64 w64 = genListN64 SM.nextWord64 $ SM.mkSMGen w64 88 | 89 | splitMix32List64 :: Word64 -> [Word64] 90 | splitMix32List64 w64 = genListN64 SM32.nextWord64 $ SM32.mkSMGen $ fromIntegral w64 91 | 92 | ------------------------------------------------------------------------------- 93 | -- Tree Word64 94 | ------------------------------------------------------------------------------- 95 | 96 | genTree64 ::(g -> (Word64, g)) -> (g -> (g, g)) -> g -> T.Tree Word64 97 | genTree64 r split = go where 98 | go g = case r g of 99 | ~(i, g') -> T.Node i $ case split g' of 100 | (ga, gb) -> [go ga, go gb] 101 | 102 | genTreeN64 :: (g -> (Word64, g)) -> (g -> (g, g)) -> g -> T.Tree Word64 103 | genTreeN64 r split = cutTree 9 . genTree64 r split 104 | where 105 | cutTree :: Word64 -> T.Tree a -> T.Tree a 106 | cutTree n (T.Node x forest) 107 | | n <= 0 = T.Node x [] 108 | | otherwise = T.Node x (map (cutTree (n - 1)) forest) 109 | 110 | randomTree64 :: Int -> T.Tree Word64 111 | randomTree64 = genTreeN64 R.random R.split . R.mkStdGen 112 | 113 | tfRandomTree64 :: Word64 -> T.Tree Word64 114 | tfRandomTree64 w64 = genTreeN64 TF.random R.split $ TF.seedTFGen (w64, w64, w64, w64) 115 | 116 | splitMixTree64 :: Word64 -> T.Tree Word64 117 | splitMixTree64 w64 = genTreeN64 SM.nextWord64 SM.splitSMGen $ SM.mkSMGen w64 118 | 119 | splitMix32Tree64 :: Word64 -> T.Tree Word64 120 | splitMix32Tree64 w64 = genTreeN64 SM32.nextWord64 SM32.splitSMGen $ SM32.mkSMGen $ fromIntegral w64 121 | 122 | ------------------------------------------------------------------------------- 123 | -- Main 124 | ------------------------------------------------------------------------------- 125 | 126 | main :: IO () 127 | main = defaultMain 128 | [ bgroup "list" 129 | [ bench "random" $ nf randomList 42 130 | , bench "tf-random" $ nf tfRandomList 42 131 | , bench "splitmix" $ nf splitMixList 42 132 | , bench "splitmix32" $ nf splitMix32List 42 133 | ] 134 | , bgroup "tree" 135 | [ bench "random" $ nf randomTree 42 136 | , bench "tf-random" $ nf tfRandomTree 42 137 | , bench "splitmix" $ nf splitMixTree 42 138 | , bench "splitmix32" $ nf splitMix32Tree 42 139 | ] 140 | , bgroup "list 64" 141 | [ bench "random" $ nf randomList64 42 142 | , bench "tf-random" $ nf tfRandomList64 42 143 | , bench "splitmix" $ nf splitMixList64 42 144 | , bench "splitmix32" $ nf splitMix32List64 42 145 | ] 146 | , bgroup "tree 64" 147 | [ bench "random" $ nf randomTree64 42 148 | , bench "tf-random" $ nf tfRandomTree64 42 149 | , bench "splitmix" $ nf splitMixTree64 42 150 | , bench "splitmix32" $ nf splitMix32Tree64 42 151 | ] 152 | ] 153 | -------------------------------------------------------------------------------- /bench/Range.hs: -------------------------------------------------------------------------------- 1 | -- http://www.pcg-random.org/posts/bounded-rands.html 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE CPP #-} 4 | module Main where 5 | 6 | import Data.Bits 7 | import Data.Bits.Compat 8 | import Data.List (unfoldr) 9 | import Data.Word (Word32, Word64) 10 | 11 | import qualified System.Random.SplitMix32 as SM 12 | 13 | #if defined(__GHCJS__) 14 | #else 15 | import System.Clock (Clock (Monotonic), getTime, toNanoSecs) 16 | import Text.Printf (printf) 17 | #endif 18 | 19 | main :: IO () 20 | main = do 21 | gen <- SM.newSMGen 22 | 23 | -- bench gen (\g h -> R (0, pred h) g) 24 | bench gen classicMod 25 | bench gen intMult 26 | bench gen bitmaskWithRejection 27 | 28 | bench :: g -> (g -> Word32 -> (Word32, g)) -> IO () 29 | bench gen next = do 30 | print $ take 70 $ unfoldr (\g -> Just (next g 10)) gen 31 | clocked $ do 32 | let x = sumOf next gen 33 | print x 34 | 35 | sumOf :: (g -> Word32 -> (Word32, g)) -> g -> Word32 36 | sumOf next = go 0 2 37 | where 38 | go !acc !n g | n > 0xfffff = acc 39 | | otherwise = let (w, g') = next g n in go (acc + w) (succ n) g' 40 | 41 | classicMod :: SM.SMGen -> Word32 -> (Word32, SM.SMGen) 42 | classicMod g h = 43 | let (w32, g') = SM.nextWord32 g in (w32 `mod` h, g') 44 | 45 | 46 | -- @ 47 | -- uint32_t bounded_rand(rng_t& rng, uint32_t range) { 48 | -- uint32_t x = rng(); 49 | -- uint64_t m = uint64_t(x) * uint64_t(range); 50 | -- return m >> 32; 51 | -- } 52 | -- @ 53 | -- 54 | intMult :: SM.SMGen -> Word32 -> (Word32, SM.SMGen) 55 | intMult g h = 56 | (fromIntegral $ (fromIntegral w32 * fromIntegral h :: Word64) `shiftR` 32, g') 57 | where 58 | (w32, g') = SM.nextWord32 g 59 | 60 | -- @ 61 | -- uint32_t bounded_rand(rng_t& rng, uint32_t range) { 62 | -- uint32_t mask = ~uint32_t(0); 63 | -- --range; 64 | -- mask >>= __builtin_clz(range|1); 65 | -- uint32_t x; 66 | -- do { 67 | -- x = rng() & mask; 68 | -- } while (x > range); 69 | -- return x; 70 | -- } 71 | -- @@ 72 | bitmaskWithRejection :: SM.SMGen -> Word32 -> (Word32, SM.SMGen) 73 | bitmaskWithRejection g0 range = go g0 74 | where 75 | mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) 76 | go g = let (x, g') = SM.nextWord32 g 77 | x' = x .&. mask 78 | in if x' >= range 79 | then go g' 80 | else (x', g') 81 | 82 | ------------------------------------------------------------------------------- 83 | -- Poor man benchmarking with GHC and GHCJS 84 | ------------------------------------------------------------------------------- 85 | 86 | clocked :: IO () -> IO () 87 | #if defined(__GHCJS__) 88 | clocked action = do 89 | start 90 | action 91 | stop 92 | 93 | foreign import javascript unsafe 94 | "console.time('loop');" 95 | start :: IO () 96 | 97 | foreign import javascript unsafe 98 | "console.timeEnd('loop');" 99 | stop :: IO () 100 | #else 101 | clocked action = do 102 | start <- getTime Monotonic 103 | action 104 | end <- getTime Monotonic 105 | printf "loop: %.03fms\n" 106 | $ fromIntegral (toNanoSecs (end - start)) 107 | / (1e6 :: Double) 108 | #endif 109 | -------------------------------------------------------------------------------- /bench/SimpleSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main (main) where 3 | 4 | import System.Environment (getArgs) 5 | import Data.List (foldl') 6 | import Data.Word (Word32) 7 | 8 | import qualified System.Random as R 9 | import qualified System.Random.SplitMix as SM 10 | import qualified System.Random.SplitMix32 as SM32 11 | 12 | newGen :: a -> (a -> g) -> IO g -> IO g 13 | #if 0 14 | newGen _ _ new = new 15 | #else 16 | newGen seed mk _ = return (mk seed) 17 | #endif 18 | 19 | main :: IO () 20 | main = do 21 | putStrLn "Summing randoms..." 22 | getArgs >>= \args -> case args of 23 | "splitmix" : _ -> newGen 33 SM.mkSMGen SM.newSMGen >>= \g -> print $ benchSum g SM.nextTwoWord32 24 | "splitmix32" : _ -> newGen 33 SM32.mkSMGen SM32.newSMGen >>= \g -> print $ benchSum g SM32.nextTwoWord32 25 | "random" : _ -> R.newStdGen >>= \g -> print $ benchSum g randomNextTwoWord32 26 | 27 | "sm-integer" : _ -> SM.newSMGen >>= \g -> print $ benchSumInteger g (SM.nextInteger two64 (two64 * 5)) 28 | "r-integer" : _ -> R.newStdGen >>= \g -> print $ benchSumInteger g (R.randomR (two64, two64 * 5)) 29 | 30 | -- after Closure Compiler getArgs return [] always? 31 | -- _ -> newGen 33 SM.mkSMGen SM.newSMGen >>= \g -> print $ benchSum g SM.nextTwoWord32 32 | _ -> newGen 33 SM32.mkSMGen SM32.newSMGen >>= \g -> print $ benchSum g SM32.nextTwoWord32 33 | 34 | 35 | benchSum :: g -> (g -> (Word32, Word32, g)) -> Word32 36 | benchSum g next = foldl' (+) 0 $ take 10000000 $ unfoldr2 next g 37 | 38 | benchSumInteger :: g -> (g -> (Integer, g)) -> Integer 39 | benchSumInteger g next = foldl' (+) 0 $ take 10000000 $ unfoldr next g 40 | 41 | -- | Infinite unfoldr with two element generator 42 | unfoldr2 :: (s -> (a, a, s)) -> s -> [a] 43 | unfoldr2 f = go where 44 | go s = let (x, y, s') = f s in x : y : go s' 45 | 46 | -- | Infinite unfoldr with one element generator 47 | unfoldr :: (s -> (a, s)) -> s -> [a] 48 | unfoldr f = go where 49 | go s = let (x, s') = f s in x : go s' 50 | 51 | randomNextTwoWord32 :: R.StdGen -> (Word32, Word32, R.StdGen) 52 | randomNextTwoWord32 s0 = (x, y, s2) where 53 | (x, s1) = R.random s0 54 | (y, s2) = R.random s1 55 | 56 | two64 :: Integer 57 | two64 = 2 ^ (64 :: Int) 58 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | docspec: True 3 | benchmarks: False 4 | apt: hugs libhugs-time-bundled libtestu01-0-dev 5 | head-hackage: False 6 | 7 | constraint-set time-1.10 8 | ghc: >=8.0 && <9.4 9 | constraints: time ^>=1.10 10 | 11 | constraint-set time-1.11 12 | ghc: >=8.0 && <9.4 13 | constraints: time ^>=1.11 14 | 15 | constraint-set time-1.12 16 | ghc: >=8.8 && <9.12 17 | constraints: time ^>=1.12 18 | tests: True 19 | run-tests: True 20 | 21 | constraint-set bytestring-0.11 22 | ghcjs: False 23 | ghc: >=7.4 && <9.7 24 | constraints: bytestring ^>=0.11 25 | tests: True 26 | run-tests: True 27 | 28 | constraint-set bytestring-0.12 29 | ghcjs: False 30 | ghc: >=8.2 31 | constraints: bytestring ^>=0.12 32 | tests: True 33 | run-tests: True 34 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | tests: True 4 | 5 | allow-newer: async-2.2.5:base 6 | allow-newer: hashable-1.4.4.0:base 7 | allow-newer: hashable-1.4.4.0:containers 8 | -------------------------------------------------------------------------------- /cbits-unix/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | uint64_t splitmix_init() { 9 | 10 | /* if there is /dev/urandom, read from it */ 11 | FILE *urandom = fopen("/dev/urandom", "r"); 12 | if (urandom) { 13 | uint64_t result = 0; 14 | size_t r = fread(&result, sizeof(uint64_t), 1, urandom); 15 | fclose(urandom); 16 | 17 | if (r == 1) { 18 | return result; 19 | } else { 20 | return 0xfeed1000; 21 | } 22 | 23 | } else { 24 | /* time of day */ 25 | struct timeval tp = {0, 0}; 26 | gettimeofday(&tp, NULL); 27 | 28 | /* cputime */ 29 | clock_t c = clock(); 30 | 31 | /* process id */ 32 | pid_t p = getpid(); 33 | 34 | return ((uint64_t) tp.tv_sec) 35 | ^ ((uint64_t) tp.tv_usec) 36 | ^ ((uint64_t) c << 16) 37 | ^ ((uint64_t) p << 32); 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /cbits-win/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | 5 | uint64_t splitmix_init() { 6 | /* Handy list at https://stackoverflow.com/a/3487338/1308058 */ 7 | 8 | uint64_t a = GetCurrentProcessId(); /* DWORD */ 9 | uint64_t b = GetCurrentThreadId(); /* DWORD */ 10 | uint64_t c = GetTickCount(); /* DWORD */ 11 | 12 | SYSTEMTIME t = {0,0,0,0,0,0,0,0}; 13 | GetSystemTime(&t); 14 | 15 | LARGE_INTEGER i; 16 | QueryPerformanceCounter(&i); 17 | 18 | return a ^ (b << 32) ^ (c << 16) 19 | ^ ((uint64_t) t.wYear << 56) 20 | ^ ((uint64_t) t.wMonth << 48) 21 | ^ ((uint64_t) t.wDayOfWeek << 40) 22 | ^ ((uint64_t) t.wDay << 32) 23 | ^ ((uint64_t) t.wHour << 24) 24 | ^ ((uint64_t) t.wMinute << 16) 25 | ^ ((uint64_t) t.wSecond << 8) 26 | ^ ((uint64_t) t.wMilliseconds << 0) 27 | ^ ((uint64_t) i.QuadPart); 28 | } 29 | -------------------------------------------------------------------------------- /make-hugs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | TOPDIR=$(dirname "$0") 6 | TARGETDIR=$TOPDIR/splitmix-hugs 7 | 8 | while getopts 't:' opt 9 | do 10 | case "$opt" in 11 | t) TARGETDIR=$OPTARG ;; 12 | *) echo "Unknown flag $opt"; exit 1 ;; 13 | esac 14 | done 15 | 16 | # Check tool availability 17 | cpphs --version 18 | 19 | # For each of the source files 20 | find "$TOPDIR/src" "$TOPDIR/src-compat" -name '*.hs' | while read -r src; do 21 | tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'\(-compat\|\)//')" 22 | 23 | echo "Processing $src -> $tgt" 24 | 25 | mkdir -p "$(dirname "$tgt")" 26 | cpphs --noline -D__HUGS__=1 "$src" > "$tgt" 27 | done 28 | 29 | echo "A Hugs-compatible version of splitmix is now" 30 | echo "available in the splitmix-hugs directory." 31 | echo "Load it with hugs -98." 32 | -------------------------------------------------------------------------------- /simple-sum.sh: -------------------------------------------------------------------------------- 1 | # shellcheck disable=SC2086 2 | set -ex 3 | 4 | GHC=ghc-8.4.4 5 | GHCJS=/opt/ghcjs/8.4/bin/ghcjs 6 | 7 | CLOSURE_OPTS="--compilation_level=SIMPLE --isolation_mode=IIFE --assume_function_wrapper --jscomp_off=*" 8 | 9 | # BUILD 10 | mkdir -p dist-newstyle 11 | 12 | cabal v2-build -O2 simple-sum -w $GHC 13 | SIMPLE_SUM_GHC=$(cabal-plan list-bin simple-sum) 14 | 15 | cabal v2-build -O2 simple-sum -w $GHCJS --ghcjs 16 | SIMPLE_SUM_GHCJS=dist-newstyle/simple-sum.js 17 | cp $(cabal-plan list-bin simple-sum).jsexe/all.js $SIMPLE_SUM_GHCJS 18 | cp $(cabal-plan list-bin simple-sum).jsexe/all.js.externs $SIMPLE_SUM_GHCJS.externs 19 | 20 | SIMPLE_SUM_GHCJS_CLOSURE=dist-newstyle/simple-sum-closure.js 21 | time java -jar /opt/closure-compiler/closure-compiler.jar $CLOSURE_OPTS \ 22 | --js "$SIMPLE_SUM_GHCJS" \ 23 | --externs "$SIMPLE_SUM_GHCJS".externs \ 24 | --js_output_file $SIMPLE_SUM_GHCJS_CLOSURE 25 | 26 | cabal v2-build -O2 simple-sum -w $GHCJS --ghcjs --constraint="splitmix +optimised-mixer" 27 | SIMPLE_SUM_GHCJS_OPT=dist-newstyle/simple-sum-optimised.js 28 | cp $(cabal-plan list-bin simple-sum).jsexe/all.js $SIMPLE_SUM_GHCJS_OPT 29 | cp $(cabal-plan list-bin simple-sum).jsexe/all.js.externs $SIMPLE_SUM_GHCJS_OPT.externs 30 | 31 | SIMPLE_SUM_GHCJS_OPT_CLOSURE=dist-newstyle/simple-sum-optimised-closure.js 32 | time java -jar /opt/closure-compiler/closure-compiler.jar $CLOSURE_OPTS \ 33 | --js "$SIMPLE_SUM_GHCJS_OPT" \ 34 | --externs "$SIMPLE_SUM_GHCJS_OPT".externs \ 35 | --js_output_file $SIMPLE_SUM_GHCJS_OPT_CLOSURE 36 | 37 | # FILESIZES 38 | ls -l \ 39 | $SIMPLE_SUM_GHC \ 40 | $SIMPLE_SUM_GHCJS \ 41 | $SIMPLE_SUM_GHCJS_CLOSURE \ 42 | $SIMPLE_SUM_GHCJS_OPT \ 43 | $SIMPLE_SUM_GHCJS_OPT_CLOSURE 44 | 45 | # RUN 46 | time $SIMPLE_SUM_GHC splitmix 47 | time $SIMPLE_SUM_GHC splitmix32 48 | time $SIMPLE_SUM_GHC random 49 | 50 | time node $SIMPLE_SUM_GHCJS splitmix 51 | time node $SIMPLE_SUM_GHCJS splitmix32 52 | # time node $SIMPLE_SUM_GHCJS random 53 | 54 | # optimised: only splitmix32 55 | time node $SIMPLE_SUM_GHCJS_CLOSURE 56 | 57 | # manual optimised 58 | time node $SIMPLE_SUM_GHCJS_OPT 59 | time node $SIMPLE_SUM_GHCJS_OPT_CLOSURE 60 | -------------------------------------------------------------------------------- /splitmix.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: splitmix 3 | version: 0.1.1 4 | synopsis: Fast Splittable PRNG 5 | description: 6 | Pure Haskell implementation of SplitMix described in 7 | . 8 | Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. 9 | Fast splittable pseudorandom number generators. In Proceedings 10 | of the 2014 ACM International Conference on Object Oriented 11 | Programming Systems Languages & Applications (OOPSLA '14). ACM, 12 | New York, NY, USA, 453-472. DOI: 13 | 14 | . 15 | The paper describes a new algorithm /SplitMix/ for /splittable/ 16 | pseudorandom number generator that is quite fast: 9 64 bit arithmetic/logical 17 | operations per 64 bits generated. 18 | . 19 | /SplitMix/ is tested with two standard statistical test suites (DieHarder and 20 | TestU01, this implementation only using the former) and it appears to be 21 | adequate for "everyday" use, such as Monte Carlo algorithms and randomized 22 | data structures where speed is important. 23 | . 24 | In particular, it __should not be used for cryptographic or security applications__, 25 | because generated sequences of pseudorandom values are too predictable 26 | (the mixing functions are easily inverted, and two successive outputs 27 | suffice to reconstruct the internal state). 28 | 29 | license: BSD3 30 | license-file: LICENSE 31 | maintainer: Oleg Grenrus 32 | bug-reports: https://github.com/haskellari/splitmix/issues 33 | category: System, Random 34 | build-type: Simple 35 | tested-with: 36 | GHC ==8.6.5 37 | || ==8.8.4 38 | || ==8.10.4 39 | || ==9.0.2 40 | || ==9.2.8 41 | || ==9.4.8 42 | || ==9.6.6 43 | || ==9.8.4 44 | || ==9.10.1 45 | || ==9.12.1 46 | 47 | extra-source-files: 48 | Changelog.md 49 | make-hugs.sh 50 | README.md 51 | test-hugs.sh 52 | 53 | flag optimised-mixer 54 | description: Use JavaScript for mix32 55 | manual: True 56 | default: False 57 | 58 | library 59 | default-language: Haskell2010 60 | ghc-options: -Wall 61 | hs-source-dirs: src src-compat 62 | exposed-modules: 63 | System.Random.SplitMix 64 | System.Random.SplitMix32 65 | 66 | other-modules: 67 | Data.Bits.Compat 68 | System.Random.SplitMix.Init 69 | 70 | -- dump-core 71 | -- build-depends: dump-core 72 | -- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html 73 | 74 | build-depends: 75 | base >=4.12.0.0 && <4.22 76 | , deepseq >=1.4.4.0 && <1.6 77 | 78 | if flag(optimised-mixer) 79 | cpp-options: -DOPTIMISED_MIX32=1 80 | 81 | -- We don't want to depend on time, nor unix or Win32 packages 82 | -- because it's valuable that splitmix and QuickCheck doesn't 83 | -- depend on about anything 84 | 85 | if impl(ghcjs) 86 | cpp-options: -DSPLITMIX_INIT_GHCJS=1 87 | 88 | else 89 | if impl(ghc) 90 | cpp-options: -DSPLITMIX_INIT_C=1 91 | 92 | if os(windows) 93 | c-sources: cbits-win/init.c 94 | 95 | else 96 | c-sources: cbits-unix/init.c 97 | 98 | else 99 | cpp-options: -DSPLITMIX_INIT_COMPAT=1 100 | build-depends: time >=1.2.0.3 && <1.15 101 | 102 | source-repository head 103 | type: git 104 | location: https://github.com/haskellari/splitmix.git 105 | 106 | benchmark comparison 107 | type: exitcode-stdio-1.0 108 | default-language: Haskell2010 109 | ghc-options: -Wall 110 | hs-source-dirs: bench 111 | main-is: Bench.hs 112 | build-depends: 113 | base 114 | , containers >=0.6.0.1 && <0.8 115 | , criterion >=1.6.0.0 && <1.7 116 | , random 117 | , splitmix 118 | , tf-random >=0.5 && <0.6 119 | 120 | benchmark simple-sum 121 | type: exitcode-stdio-1.0 122 | default-language: Haskell2010 123 | ghc-options: -Wall 124 | hs-source-dirs: bench 125 | main-is: SimpleSum.hs 126 | build-depends: 127 | base 128 | , random 129 | , splitmix 130 | 131 | benchmark range 132 | type: exitcode-stdio-1.0 133 | default-language: Haskell2010 134 | ghc-options: -Wall 135 | hs-source-dirs: bench src-compat 136 | main-is: Range.hs 137 | other-modules: Data.Bits.Compat 138 | build-depends: 139 | base 140 | , random 141 | , splitmix 142 | 143 | test-suite examples 144 | type: exitcode-stdio-1.0 145 | default-language: Haskell2010 146 | ghc-options: -Wall 147 | hs-source-dirs: tests 148 | main-is: Examples.hs 149 | build-depends: 150 | base 151 | , HUnit >=1.6.0.0 && <1.7 152 | , splitmix 153 | 154 | test-suite splitmix-tests 155 | type: exitcode-stdio-1.0 156 | default-language: Haskell2010 157 | ghc-options: -Wall 158 | hs-source-dirs: tests 159 | main-is: Tests.hs 160 | other-modules: 161 | MiniQC 162 | Uniformity 163 | 164 | build-depends: 165 | base 166 | , containers >=0.4.0.0 && <0.8 167 | , HUnit >=1.6.0.0 && <1.7 168 | , math-functions >=0.3.3.0 && <0.4 169 | , splitmix 170 | , test-framework >=0.8.2.0 && <0.9 171 | , test-framework-hunit >=0.3.0.2 && <0.4 172 | 173 | test-suite montecarlo-pi 174 | type: exitcode-stdio-1.0 175 | default-language: Haskell2010 176 | ghc-options: -Wall 177 | hs-source-dirs: tests 178 | main-is: SplitMixPi.hs 179 | build-depends: 180 | base 181 | , splitmix 182 | 183 | test-suite montecarlo-pi-32 184 | type: exitcode-stdio-1.0 185 | default-language: Haskell2010 186 | ghc-options: -Wall 187 | hs-source-dirs: tests 188 | main-is: SplitMixPi32.hs 189 | build-depends: 190 | base 191 | , splitmix 192 | 193 | test-suite splitmix-dieharder 194 | default-language: Haskell2010 195 | type: exitcode-stdio-1.0 196 | ghc-options: -Wall -threaded -rtsopts 197 | hs-source-dirs: tests 198 | main-is: Dieharder.hs 199 | build-depends: 200 | async >=2.2.1 && <2.3 201 | , base 202 | , bytestring >=0.10.8.2 && <0.13 203 | , deepseq 204 | , process >=1.6.0.0 && <1.7 205 | , random 206 | , splitmix 207 | , tf-random >=0.5 && <0.6 208 | , vector >=0.13.0.0 && <0.14 209 | 210 | test-suite splitmix-testu01 211 | if !os(linux) 212 | buildable: False 213 | 214 | default-language: Haskell2010 215 | type: exitcode-stdio-1.0 216 | ghc-options: -Wall -threaded -rtsopts 217 | hs-source-dirs: tests 218 | main-is: TestU01.hs 219 | c-sources: tests/cbits/testu01.c 220 | extra-libraries: testu01 221 | build-depends: 222 | base 223 | , base-compat-batteries >=0.10.5 && <0.15 224 | , splitmix 225 | 226 | test-suite initialization 227 | default-language: Haskell2010 228 | type: exitcode-stdio-1.0 229 | ghc-options: -Wall -threaded -rtsopts 230 | hs-source-dirs: tests 231 | main-is: Initialization.hs 232 | build-depends: 233 | base 234 | , HUnit >=1.6.0.0 && <1.7 235 | , splitmix 236 | -------------------------------------------------------------------------------- /src-compat/Data/Bits/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Data.Bits.Compat ( 3 | popCount, 4 | zeroBits, 5 | finiteBitSize, 6 | countLeadingZeros, 7 | ) where 8 | 9 | import Data.Bits (popCount, zeroBits, finiteBitSize, countLeadingZeros) 10 | -------------------------------------------------------------------------------- /src/System/Random/SplitMix.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- /SplitMix/ is a splittable pseudorandom number generator (PRNG) that is quite fast. 3 | -- 4 | -- Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. 5 | -- Fast splittable pseudorandom number generators. In Proceedings 6 | -- of the 2014 ACM International Conference on Object Oriented 7 | -- Programming Systems Languages & Applications (OOPSLA '14). ACM, 8 | -- New York, NY, USA, 453-472. DOI: 9 | -- 10 | -- 11 | -- The paper describes a new algorithm /SplitMix/ for /splittable/ 12 | -- pseudorandom number generator that is quite fast: 9 64 bit arithmetic/logical 13 | -- operations per 64 bits generated. 14 | -- 15 | -- /SplitMix/ is tested with two standard statistical test suites (DieHarder and 16 | -- TestU01, this implementation only using the former) and it appears to be 17 | -- adequate for "everyday" use, such as Monte Carlo algorithms and randomized 18 | -- data structures where speed is important. 19 | -- 20 | -- In particular, it __should not be used for cryptographic or security applications__, 21 | -- because generated sequences of pseudorandom values are too predictable 22 | -- (the mixing functions are easily inverted, and two successive outputs 23 | -- suffice to reconstruct the internal state). 24 | -- 25 | {-# LANGUAGE CPP #-} 26 | {-# LANGUAGE Trustworthy #-} 27 | module System.Random.SplitMix ( 28 | SMGen, 29 | nextWord64, 30 | nextWord32, 31 | nextTwoWord32, 32 | nextInt, 33 | nextDouble, 34 | nextFloat, 35 | nextInteger, 36 | splitSMGen, 37 | -- * Generation 38 | bitmaskWithRejection32, 39 | bitmaskWithRejection32', 40 | bitmaskWithRejection64, 41 | bitmaskWithRejection64', 42 | -- * Initialisation 43 | mkSMGen, 44 | initSMGen, 45 | newSMGen, 46 | seedSMGen, 47 | seedSMGen', 48 | unseedSMGen, 49 | ) where 50 | 51 | import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) 52 | import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits) 53 | import Data.IORef (IORef, atomicModifyIORef, newIORef) 54 | import Data.Word (Word32, Word64) 55 | import System.IO.Unsafe (unsafePerformIO) 56 | 57 | import System.Random.SplitMix.Init 58 | 59 | #if defined(__HUGS__) 60 | import Data.Word (Word) 61 | #endif 62 | 63 | #ifndef __HUGS__ 64 | import Control.DeepSeq (NFData (..)) 65 | #endif 66 | 67 | -- $setup 68 | -- >>> import Text.Read (readMaybe) 69 | -- >>> import Data.List (unfoldr) 70 | -- >>> import Text.Printf (printf) 71 | 72 | ------------------------------------------------------------------------------- 73 | -- Generator 74 | ------------------------------------------------------------------------------- 75 | 76 | -- | SplitMix generator state. 77 | data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd 78 | deriving Show 79 | 80 | #ifndef __HUGS__ 81 | instance NFData SMGen where 82 | rnf (SMGen _ _) = () 83 | #endif 84 | 85 | -- | 86 | -- 87 | -- >>> readMaybe "SMGen 1 1" :: Maybe SMGen 88 | -- Just (SMGen 1 1) 89 | -- 90 | -- >>> readMaybe "SMGen 1 2" :: Maybe SMGen 91 | -- Nothing 92 | -- 93 | -- >>> readMaybe (show (mkSMGen 42)) :: Maybe SMGen 94 | -- Just (SMGen 9297814886316923340 13679457532755275413) 95 | -- 96 | instance Read SMGen where 97 | readsPrec d r = readParen (d > 10) (\r0 -> 98 | [ (SMGen seed gamma, r3) 99 | | ("SMGen", r1) <- lex r0 100 | , (seed, r2) <- readsPrec 11 r1 101 | , (gamma, r3) <- readsPrec 11 r2 102 | , odd gamma 103 | ]) r 104 | 105 | ------------------------------------------------------------------------------- 106 | -- Operations 107 | ------------------------------------------------------------------------------- 108 | 109 | -- | Generate a 'Word64'. 110 | -- 111 | -- >>> take 3 $ map (printf "%x") $ unfoldr (Just . nextWord64) (mkSMGen 1337) :: [String] 112 | -- ["b5c19e300e8b07b3","d600e0e216c0ac76","c54efc3b3cc5af29"] 113 | -- 114 | nextWord64 :: SMGen -> (Word64, SMGen) 115 | nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma) 116 | where 117 | seed' = seed `plus` gamma 118 | 119 | -- | Generate 'Word32' by truncating 'nextWord64'. 120 | -- 121 | -- @since 0.0.3 122 | nextWord32 :: SMGen -> (Word32, SMGen) 123 | nextWord32 g = 124 | #ifdef __HUGS__ 125 | (fromIntegral $ w64 .&. 0xffffffff, g') 126 | #else 127 | (fromIntegral w64, g') 128 | #endif 129 | where 130 | (w64, g') = nextWord64 g 131 | 132 | -- | Generate two 'Word32'. 133 | -- 134 | -- @since 0.0.3 135 | nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen) 136 | nextTwoWord32 g = 137 | #ifdef __HUGS__ 138 | (fromIntegral $ w64 `shiftR` 32, fromIntegral $ w64 .&. 0xffffffff, g') 139 | #else 140 | (fromIntegral $ w64 `shiftR` 32, fromIntegral w64, g') 141 | #endif 142 | where 143 | (w64, g') = nextWord64 g 144 | 145 | -- | Generate an 'Int'. 146 | nextInt :: SMGen -> (Int, SMGen) 147 | nextInt g = case nextWord64 g of 148 | #ifdef __HUGS__ 149 | (w64, g') -> (fromIntegral $ w64 `shiftR` 32, g') 150 | #else 151 | (w64, g') -> (fromIntegral w64, g') 152 | #endif 153 | 154 | -- | Generate a 'Double' in @[0, 1)@ range. 155 | -- 156 | -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextDouble) (mkSMGen 1337) :: [String] 157 | -- ["0.710","0.836","0.771","0.409","0.297","0.527","0.589","0.067"] 158 | -- 159 | nextDouble :: SMGen -> (Double, SMGen) 160 | nextDouble g = case nextWord64 g of 161 | (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g') 162 | 163 | -- | Generate a 'Float' in @[0, 1)@ range. 164 | -- 165 | -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextFloat) (mkSMGen 1337) :: [String] 166 | -- ["0.057","0.089","0.237","0.383","0.680","0.320","0.826","0.007"] 167 | -- 168 | -- @since 0.0.3 169 | nextFloat :: SMGen -> (Float, SMGen) 170 | nextFloat g = case nextWord32 g of 171 | (w32, g') -> (fromIntegral (w32 `shiftR` 8) * floatUlp, g') 172 | 173 | -- | Generate an 'Integer' in closed @[x, y]@ range. 174 | nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen) 175 | nextInteger lo hi g = case compare lo hi of 176 | LT -> let (i, g') = nextInteger' (hi - lo) g in (i + lo, g') 177 | EQ -> (lo, g) 178 | GT -> let (i, g') = nextInteger' (lo - hi) g in (i + hi, g') 179 | 180 | -- invariant: first argument is positive 181 | -- Essentially bitmaskWithRejection but for Integers. 182 | -- 183 | nextInteger' :: Integer -> SMGen -> (Integer, SMGen) 184 | nextInteger' range = loop 185 | where 186 | leadMask :: Word64 187 | restDigits :: Word 188 | (leadMask, restDigits) = go 0 range where 189 | go :: Word -> Integer -> (Word64, Word) 190 | go n x | x < two64 = (complement zeroBits `shiftR` countLeadingZeros (fromInteger x :: Word64), n) 191 | | otherwise = go (n + 1) (x `shiftR` 64) 192 | 193 | generate :: SMGen -> (Integer, SMGen) 194 | generate g0 = 195 | let (x, g') = nextWord64 g0 196 | x' = x .&. leadMask 197 | in go (fromIntegral x') restDigits g' 198 | where 199 | go :: Integer -> Word -> SMGen -> (Integer, SMGen) 200 | go acc 0 g = acc `seq` (acc, g) 201 | go acc n g = 202 | let (x, g') = nextWord64 g 203 | in go (acc * two64 + fromIntegral x) (n - 1) g' 204 | 205 | loop g = let (x, g') = generate g 206 | in if x > range 207 | then loop g' 208 | else (x, g') 209 | 210 | two64 :: Integer 211 | two64 = 2 ^ (64 :: Int) 212 | 213 | ------------------------------------------------------------------------------- 214 | -- Splitting 215 | ------------------------------------------------------------------------------- 216 | 217 | -- | Split a generator into a two uncorrelated generators. 218 | splitSMGen :: SMGen -> (SMGen, SMGen) 219 | splitSMGen (SMGen seed gamma) = 220 | (SMGen seed'' gamma, SMGen (mix64 seed') (mixGamma seed'')) 221 | where 222 | seed' = seed `plus` gamma 223 | seed'' = seed' `plus` gamma 224 | 225 | ------------------------------------------------------------------------------- 226 | -- Algorithm 227 | ------------------------------------------------------------------------------- 228 | 229 | goldenGamma :: Word64 230 | goldenGamma = 0x9e3779b97f4a7c15 231 | 232 | floatUlp :: Float 233 | floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32) 234 | 235 | doubleUlp :: Double 236 | doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64) 237 | 238 | -- Note: in JDK implementations the mix64 and mix64variant13 239 | -- (which is inlined into mixGamma) are swapped. 240 | mix64 :: Word64 -> Word64 241 | mix64 z0 = 242 | -- MurmurHash3Mixer 243 | let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0 244 | z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1 245 | z3 = shiftXor 33 z2 246 | in z3 247 | 248 | -- used only in mixGamma 249 | mix64variant13 :: Word64 -> Word64 250 | mix64variant13 z0 = 251 | -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer 252 | -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html 253 | -- 254 | -- Stafford's Mix13 255 | let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants 256 | z2 = shiftXorMultiply 27 0x94d049bb133111eb z1 257 | z3 = shiftXor 31 z2 258 | in z3 259 | 260 | mixGamma :: Word64 -> Word64 261 | mixGamma z0 = 262 | let z1 = mix64variant13 z0 .|. 1 -- force to be odd 263 | n = popCount (z1 `xor` (z1 `shiftR` 1)) 264 | -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html 265 | -- let's trust the text of the paper, not the code. 266 | in if n >= 24 267 | then z1 268 | else z1 `xor` 0xaaaaaaaaaaaaaaaa 269 | 270 | shiftXor :: Int -> Word64 -> Word64 271 | shiftXor n w = w `xor` (w `shiftR` n) 272 | 273 | shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64 274 | shiftXorMultiply n k w = shiftXor n w `mult` k 275 | 276 | 277 | ------------------------------------------------------------------------------- 278 | -- Generation 279 | ------------------------------------------------------------------------------- 280 | 281 | -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. 282 | -- 283 | -- @bitmaskWithRejection32 w32@ generates random numbers in closed-open 284 | -- range of @[0, w32)@. 285 | -- 286 | -- @since 0.0.3 287 | bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen) 288 | bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" 289 | bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) 290 | {-# INLINEABLE bitmaskWithRejection32 #-} 291 | 292 | -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. 293 | -- 294 | -- @bitmaskWithRejection64 w64@ generates random numbers in closed-open 295 | -- range of @[0, w64)@. 296 | -- 297 | -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64 5) (mkSMGen 1337) 298 | -- [3,1,4,1,2,3,1,1,0,3,4,2,3,0,2,3,3,4,1,0] 299 | -- 300 | -- @since 0.0.3 301 | bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen) 302 | bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0" 303 | bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1) 304 | {-# INLINEABLE bitmaskWithRejection64 #-} 305 | 306 | -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. 307 | -- 308 | -- @bitmaskWithRejection32' w32@ generates random numbers in closed-closed 309 | -- range of @[0, w32]@. 310 | -- 311 | -- @since 0.0.4 312 | bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen) 313 | bitmaskWithRejection32' range = go where 314 | mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) 315 | go g = let (x, g') = nextWord32 g 316 | x' = x .&. mask 317 | in if x' > range 318 | then go g' 319 | else (x', g') 320 | {-# INLINEABLE bitmaskWithRejection32' #-} 321 | 322 | -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. 323 | -- 324 | -- @bitmaskWithRejection64' w64@ generates random numbers in closed-closed 325 | -- range of @[0, w64]@. 326 | -- 327 | -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64' 5) (mkSMGen 1337) 328 | -- [3,1,4,1,2,3,1,1,0,3,4,5,2,3,0,2,3,5,3,4] 329 | -- 330 | -- @since 0.0.4 331 | bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen) 332 | bitmaskWithRejection64' range = go where 333 | mask = complement zeroBits `shiftR` countLeadingZeros range 334 | go g = let (x, g') = nextWord64 g 335 | x' = x .&. mask 336 | in if x' > range 337 | then go g' 338 | else (x', g') 339 | {-# INLINEABLE bitmaskWithRejection64' #-} 340 | 341 | 342 | ------------------------------------------------------------------------------- 343 | -- Initialisation 344 | ------------------------------------------------------------------------------- 345 | 346 | -- | Create 'SMGen' using seed and gamma. 347 | -- 348 | -- >>> seedSMGen 2 2 349 | -- SMGen 2 3 350 | -- 351 | seedSMGen 352 | :: Word64 -- ^ seed 353 | -> Word64 -- ^ gamma 354 | -> SMGen 355 | seedSMGen seed gamma = SMGen seed (gamma .|. 1) 356 | 357 | -- | Like 'seedSMGen' but takes a pair. 358 | seedSMGen' :: (Word64, Word64) -> SMGen 359 | seedSMGen' = uncurry seedSMGen 360 | 361 | -- | Extract current state of 'SMGen'. 362 | unseedSMGen :: SMGen -> (Word64, Word64) 363 | unseedSMGen (SMGen seed gamma) = (seed, gamma) 364 | 365 | -- | Preferred way to deterministically construct 'SMGen'. 366 | -- 367 | -- >>> mkSMGen 42 368 | -- SMGen 9297814886316923340 13679457532755275413 369 | -- 370 | mkSMGen :: Word64 -> SMGen 371 | mkSMGen s = SMGen (mix64 s) (mixGamma (s `plus` goldenGamma)) 372 | 373 | -- | Initialize 'SMGen' using entropy available on the system (time, ...) 374 | initSMGen :: IO SMGen 375 | initSMGen = fmap mkSMGen initialSeed 376 | 377 | -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. 378 | newSMGen :: IO SMGen 379 | newSMGen = atomicModifyIORef theSMGen splitSMGen 380 | 381 | theSMGen :: IORef SMGen 382 | theSMGen = unsafePerformIO $ initSMGen >>= newIORef 383 | {-# NOINLINE theSMGen #-} 384 | 385 | ------------------------------------------------------------------------------- 386 | -- Hugs 387 | ------------------------------------------------------------------------------- 388 | 389 | mult, plus :: Word64 -> Word64 -> Word64 390 | #ifndef __HUGS__ 391 | mult = (*) 392 | plus = (+) 393 | #else 394 | -- Hugs defines: 395 | -- 396 | -- x * y = fromInteger (toInteger x * toInteger y) 397 | -- x + y = fromInteger (toInteger x + toInteger y) 398 | -- 399 | -- which obviously overflows in our use cases, as fromInteger doesn't truncate 400 | -- 401 | mult x y = fromInteger ((toInteger x * toInteger y) `mod` 18446744073709551616) 402 | plus x y = fromInteger ((toInteger x + toInteger y) `mod` 18446744073709551616) 403 | #endif 404 | -------------------------------------------------------------------------------- /src/System/Random/SplitMix/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Initialization of global generator. 3 | module System.Random.SplitMix.Init ( 4 | initialSeed, 5 | ) where 6 | 7 | import Data.Word (Word64) 8 | 9 | #if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__ 10 | 11 | import Data.Word (Word32) 12 | 13 | #else 14 | #if defined(SPLITMIX_INIT_C) 15 | 16 | #else 17 | 18 | import Data.Bits (xor) 19 | import Data.Time.Clock.POSIX (getPOSIXTime) 20 | #if !__GHCJS__ 21 | import System.CPUTime (cpuTimePrecision, getCPUTime) 22 | #endif 23 | 24 | #endif 25 | #endif 26 | 27 | initialSeed :: IO Word64 28 | 29 | #if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__ 30 | 31 | initialSeed = fmap fromIntegral initialSeedJS 32 | 33 | foreign import javascript 34 | "$r = Math.floor(Math.random()*0x100000000);" 35 | initialSeedJS :: IO Word32 36 | 37 | #else 38 | #if defined(SPLITMIX_INIT_C) 39 | 40 | initialSeed = initialSeedC 41 | 42 | foreign import ccall "splitmix_init" initialSeedC :: IO Word64 43 | 44 | #else 45 | 46 | initialSeed = do 47 | now <- getPOSIXTime 48 | let timebits = truncate now :: Word64 49 | #if __GHCJS__ 50 | let cpubits = 0 51 | #else 52 | cpu <- getCPUTime 53 | let cpubits = fromIntegral (cpu `div` cpuTimePrecision) :: Word64 54 | #endif 55 | return $ timebits `xor` cpubits 56 | 57 | #endif 58 | #endif 59 | -------------------------------------------------------------------------------- /src/System/Random/SplitMix32.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- /SplitMix/ is a splittable pseudorandom number generator (PRNG) that is quite fast. 3 | -- 4 | -- This is 32bit variant (original one is 32 bit). 5 | -- 6 | -- You __really don't want to use this one__. 7 | -- 8 | {-# LANGUAGE CPP #-} 9 | {-# LANGUAGE Trustworthy #-} 10 | module System.Random.SplitMix32 ( 11 | SMGen, 12 | nextWord32, 13 | nextWord64, 14 | nextTwoWord32, 15 | nextInt, 16 | nextDouble, 17 | nextFloat, 18 | nextInteger, 19 | splitSMGen, 20 | -- * Generation 21 | bitmaskWithRejection32, 22 | bitmaskWithRejection32', 23 | bitmaskWithRejection64, 24 | bitmaskWithRejection64', 25 | -- * Initialisation 26 | mkSMGen, 27 | initSMGen, 28 | newSMGen, 29 | seedSMGen, 30 | seedSMGen', 31 | unseedSMGen, 32 | ) where 33 | 34 | import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) 35 | import Data.Bits.Compat 36 | (countLeadingZeros, finiteBitSize, popCount, zeroBits) 37 | import Data.IORef (IORef, atomicModifyIORef, newIORef) 38 | import Data.Word (Word32, Word64) 39 | import System.IO.Unsafe (unsafePerformIO) 40 | 41 | import System.Random.SplitMix.Init 42 | 43 | #if defined(__HUGS__) 44 | import Data.Word (Word) 45 | #endif 46 | 47 | #ifndef __HUGS__ 48 | import Control.DeepSeq (NFData (..)) 49 | #endif 50 | 51 | -- $setup 52 | -- >>> import Text.Read (readMaybe) 53 | -- >>> import Data.List (unfoldr) 54 | -- >>> import Text.Printf (printf) 55 | 56 | ------------------------------------------------------------------------------- 57 | -- Generator 58 | ------------------------------------------------------------------------------- 59 | 60 | -- | SplitMix generator state. 61 | data SMGen = SMGen {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 -- seed and gamma; gamma is odd 62 | deriving Show 63 | 64 | #ifndef __HUGS__ 65 | instance NFData SMGen where 66 | rnf (SMGen _ _) = () 67 | #endif 68 | 69 | -- | 70 | -- 71 | -- >>> readMaybe "SMGen 1 1" :: Maybe SMGen 72 | -- Just (SMGen 1 1) 73 | -- 74 | -- >>> readMaybe "SMGen 1 2" :: Maybe SMGen 75 | -- Nothing 76 | -- 77 | -- >>> readMaybe (show (mkSMGen 42)) :: Maybe SMGen 78 | -- Just (SMGen 142593372 1604540297) 79 | -- 80 | instance Read SMGen where 81 | readsPrec d r = readParen (d > 10) (\r0 -> 82 | [ (SMGen seed gamma, r3) 83 | | ("SMGen", r1) <- lex r0 84 | , (seed, r2) <- readsPrec 11 r1 85 | , (gamma, r3) <- readsPrec 11 r2 86 | , odd gamma 87 | ]) r 88 | 89 | ------------------------------------------------------------------------------- 90 | -- Operations 91 | ------------------------------------------------------------------------------- 92 | 93 | -- | Generate a 'Word32'. 94 | -- 95 | -- >>> take 3 $ map (printf "%x") $ unfoldr (Just . nextWord32) (mkSMGen 1337) :: [String] 96 | -- ["e0cfe722","a6ced0f0","c3a6d889"] 97 | -- 98 | nextWord32 :: SMGen -> (Word32, SMGen) 99 | nextWord32 (SMGen seed gamma) = (mix32 seed', SMGen seed' gamma) 100 | where 101 | seed' = seed + gamma 102 | 103 | -- | Generate a 'Word64', by generating to 'Word32's. 104 | nextWord64 :: SMGen -> (Word64, SMGen) 105 | nextWord64 s0 = (fromIntegral w0 `shiftL` 32 .|. fromIntegral w1, s2) 106 | where 107 | (w0, s1) = nextWord32 s0 108 | (w1, s2) = nextWord32 s1 109 | 110 | -- | Generate two 'Word32'. 111 | nextTwoWord32 :: SMGen -> (Word32, Word32, SMGen) 112 | nextTwoWord32 s0 = (w0, w1, s2) where 113 | (w0, s1) = nextWord32 s0 114 | (w1, s2) = nextWord32 s1 115 | 116 | -- | Generate an 'Int'. 117 | nextInt :: SMGen -> (Int, SMGen) 118 | nextInt g | isBigInt = int64 119 | | otherwise = int32 120 | where 121 | int32 = case nextWord32 g of 122 | (w, g') -> (fromIntegral w, g') 123 | int64 = case nextWord64 g of 124 | (w, g') -> (fromIntegral w, g') 125 | 126 | isBigInt :: Bool 127 | isBigInt = finiteBitSize (undefined :: Int) > 32 128 | 129 | -- | Generate a 'Double' in @[0, 1)@ range. 130 | -- 131 | -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextDouble) (mkSMGen 1337) :: [String] 132 | -- ["0.878","0.764","0.063","0.845","0.262","0.490","0.176","0.544"] 133 | -- 134 | nextDouble :: SMGen -> (Double, SMGen) 135 | nextDouble g = case nextWord64 g of 136 | (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g') 137 | 138 | -- | Generate a 'Float' in @[0, 1)@ range. 139 | -- 140 | -- >>> take 8 $ map (printf "%0.3f") $ unfoldr (Just . nextFloat) (mkSMGen 1337) :: [String] 141 | -- ["0.878","0.652","0.764","0.631","0.063","0.180","0.845","0.645"] 142 | -- 143 | nextFloat :: SMGen -> (Float, SMGen) 144 | nextFloat g = case nextWord32 g of 145 | (w32, g') -> (fromIntegral (w32 `shiftR` 8) * floatUlp, g') 146 | 147 | -- | Generate an 'Integer' in closed @[x, y]@ range. 148 | nextInteger :: Integer -> Integer -> SMGen -> (Integer, SMGen) 149 | nextInteger lo hi g = case compare lo hi of 150 | LT -> let (i, g') = nextInteger' (hi - lo) g in (i + lo, g') 151 | EQ -> (lo, g) 152 | GT -> let (i, g') = nextInteger' (lo - hi) g in (i + hi, g') 153 | 154 | -- invariant: first argument is positive 155 | -- Essentially bitmaskWithRejection but for Integers. 156 | -- 157 | nextInteger' :: Integer -> SMGen -> (Integer, SMGen) 158 | nextInteger' range = loop 159 | where 160 | leadMask :: Word32 161 | restDigits :: Word 162 | (leadMask, restDigits) = go 0 range where 163 | go :: Word -> Integer -> (Word32, Word) 164 | go n x | x < two32 = (complement zeroBits `shiftR` countLeadingZeros (fromInteger x :: Word32), n) 165 | | otherwise = go (n + 1) (x `shiftR` 32) 166 | 167 | generate :: SMGen -> (Integer, SMGen) 168 | generate g0 = 169 | let (x, g') = nextWord32 g0 170 | x' = x .&. leadMask 171 | in go (fromIntegral x') restDigits g' 172 | where 173 | go :: Integer -> Word -> SMGen -> (Integer, SMGen) 174 | go acc 0 g = acc `seq` (acc, g) 175 | go acc n g = 176 | let (x, g') = nextWord32 g 177 | in go (acc * two32 + fromIntegral x) (n - 1) g' 178 | 179 | loop g = let (x, g') = generate g 180 | in if x > range 181 | then loop g' 182 | else (x, g') 183 | 184 | two32 :: Integer 185 | two32 = 2 ^ (32 :: Int) 186 | 187 | ------------------------------------------------------------------------------- 188 | -- Splitting 189 | ------------------------------------------------------------------------------- 190 | 191 | -- | Split a generator into a two uncorrelated generators. 192 | splitSMGen :: SMGen -> (SMGen, SMGen) 193 | splitSMGen (SMGen seed gamma) = 194 | (SMGen seed'' gamma, SMGen (mix32 seed') (mixGamma seed'')) 195 | where 196 | seed' = seed + gamma 197 | seed'' = seed' + gamma 198 | 199 | ------------------------------------------------------------------------------- 200 | -- Algorithm 201 | ------------------------------------------------------------------------------- 202 | 203 | -- | (1 + sqrt 5) / 2 * (2 ^^ bits) 204 | goldenGamma :: Word32 205 | goldenGamma = 0x9e3779b9 206 | 207 | floatUlp :: Float 208 | floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32) 209 | 210 | doubleUlp :: Double 211 | doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64) 212 | 213 | #if defined(__GHCJS__) && defined(OPTIMISED_MIX32) 214 | -- JavaScript Foreign Function Interface 215 | -- https://github.com/ghcjs/ghcjs/blob/master/doc/foreign-function-interface.md 216 | 217 | foreign import javascript unsafe 218 | "var x0 = $1 ^ $1 >>> 16; var x1 = x0 & 0xffff; var x2 = (((x0 >>> 16 & 0xffff) * 0x0000ca6b + x1 * 0x000085eb & 0xffff) << 16) + x1 * 0x0000ca6b; var x3 = x2 ^ x2 >>> 13; var x4 = x3 & 0xffff; var x5 = (((x3 >>> 16 & 0xffff) * 0x0000ae35 + x4 * 0x0000c2b2 & 0xffff) << 16) + x4 * 0x0000ae35; $r = (x5 ^ x5 >>> 16) | 0;" 219 | mix32 :: Word32 -> Word32 220 | 221 | foreign import javascript unsafe 222 | "var x0 = $1 ^ $1 >>> 16; var x1 = x0 & 0xffff; var x2 = (((x0 >>> 16 & 0xffff) * 0x00006ccb + x1 * 0x000069ad & 0xffff) << 16) + x1 * 0x00006ccb; var x3 = x2 ^ x2 >>> 13; var x4 = x3 & 0xffff; var x5 = (((x3 >>> 16 & 0xffff) * 0x0000b5b3 + x4 * 0x0000cd9a & 0xffff) << 16) + x4 * 0x0000b5b3; $r = (x5 ^ x5 >>> 16) | 0;" 223 | mix32variant13 :: Word32 -> Word32 224 | 225 | #else 226 | mix32 :: Word32 -> Word32 227 | mix32 z0 = 228 | -- MurmurHash3Mixer 32bit 229 | let z1 = shiftXorMultiply 16 0x85ebca6b z0 230 | z2 = shiftXorMultiply 13 0xc2b2ae35 z1 231 | z3 = shiftXor 16 z2 232 | in z3 233 | 234 | -- used only in mixGamma 235 | mix32variant13 :: Word32 -> Word32 236 | mix32variant13 z0 = 237 | -- See avalanche "executable" 238 | let z1 = shiftXorMultiply 16 0x69ad6ccb z0 239 | z2 = shiftXorMultiply 13 0xcd9ab5b3 z1 240 | z3 = shiftXor 16 z2 241 | in z3 242 | 243 | shiftXor :: Int -> Word32 -> Word32 244 | shiftXor n w = w `xor` (w `shiftR` n) 245 | 246 | shiftXorMultiply :: Int -> Word32 -> Word32 -> Word32 247 | shiftXorMultiply n k w = shiftXor n w * k 248 | #endif 249 | 250 | mixGamma :: Word32 -> Word32 251 | mixGamma z0 = 252 | let z1 = mix32variant13 z0 .|. 1 -- force to be odd 253 | n = popCount (z1 `xor` (z1 `shiftR` 1)) 254 | -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html 255 | -- let's trust the text of the paper, not the code. 256 | in if n >= 12 257 | then z1 258 | else z1 `xor` 0xaaaaaaaa 259 | 260 | ------------------------------------------------------------------------------- 261 | -- Generation 262 | ------------------------------------------------------------------------------- 263 | 264 | -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. 265 | -- 266 | -- @bitmaskWithRejection32 w32@ generates random numbers in closed-open 267 | -- range of @[0, w32)@. 268 | -- 269 | bitmaskWithRejection32 :: Word32 -> SMGen -> (Word32, SMGen) 270 | bitmaskWithRejection32 0 = error "bitmaskWithRejection32 0" 271 | bitmaskWithRejection32 n = bitmaskWithRejection32' (n - 1) 272 | {-# INLINEABLE bitmaskWithRejection32 #-} 273 | 274 | -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. 275 | -- 276 | -- @bitmaskWithRejection64 w64@ generates random numbers in closed-open 277 | -- range of @[0, w64)@. 278 | -- 279 | -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64 5) (mkSMGen 1337) 280 | -- [0,2,4,2,1,4,2,4,2,2,3,0,3,2,2,2,3,1,2,2] 281 | -- 282 | bitmaskWithRejection64 :: Word64 -> SMGen -> (Word64, SMGen) 283 | bitmaskWithRejection64 0 = error "bitmaskWithRejection64 0" 284 | bitmaskWithRejection64 n = bitmaskWithRejection64' (n - 1) 285 | {-# INLINEABLE bitmaskWithRejection64 #-} 286 | 287 | -- | /Bitmask with rejection/ method of generating subrange of 'Word32'. 288 | -- 289 | -- @bitmaskWithRejection32' w32@ generates random numbers in closed-closed 290 | -- range of @[0, w32]@. 291 | -- 292 | -- @since 0.0.4 293 | bitmaskWithRejection32' :: Word32 -> SMGen -> (Word32, SMGen) 294 | bitmaskWithRejection32' range = go where 295 | mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) 296 | go g = let (x, g') = nextWord32 g 297 | x' = x .&. mask 298 | in if x' > range 299 | then go g' 300 | else (x', g') 301 | {-# INLINEABLE bitmaskWithRejection32' #-} 302 | 303 | -- | /Bitmask with rejection/ method of generating subrange of 'Word64'. 304 | -- 305 | -- @bitmaskWithRejection64' w64@ generates random numbers in closed-closed 306 | -- range of @[0, w64]@. 307 | -- 308 | -- >>> take 20 $ unfoldr (Just . bitmaskWithRejection64' 5) (mkSMGen 1337) 309 | -- [0,2,4,2,1,4,2,4,5,5,2,2,5,3,5,0,3,2,2,2] 310 | -- 311 | -- @since 0.0.4 312 | bitmaskWithRejection64' :: Word64 -> SMGen -> (Word64, SMGen) 313 | bitmaskWithRejection64' range = go where 314 | mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1) 315 | go g = let (x, g') = nextWord64 g 316 | x' = x .&. mask 317 | in if x' > range 318 | then go g' 319 | else (x', g') 320 | {-# INLINEABLE bitmaskWithRejection64' #-} 321 | 322 | ------------------------------------------------------------------------------- 323 | -- Initialisation 324 | ------------------------------------------------------------------------------- 325 | 326 | -- | Create 'SMGen' using seed and gamma. 327 | -- 328 | -- >>> seedSMGen 2 2 329 | -- SMGen 2 3 330 | -- 331 | seedSMGen 332 | :: Word32 -- ^ seed 333 | -> Word32 -- ^ gamma 334 | -> SMGen 335 | seedSMGen seed gamma = SMGen seed (gamma .|. 1) 336 | 337 | -- | Like 'seedSMGen' but takes a pair. 338 | seedSMGen' :: (Word32, Word32) -> SMGen 339 | seedSMGen' = uncurry seedSMGen 340 | 341 | -- | Extract current state of 'SMGen'. 342 | unseedSMGen :: SMGen -> (Word32, Word32) 343 | unseedSMGen (SMGen seed gamma) = (seed, gamma) 344 | 345 | -- | Preferred way to deterministically construct 'SMGen'. 346 | -- 347 | -- >>> mkSMGen 42 348 | -- SMGen 142593372 1604540297 349 | -- 350 | mkSMGen :: Word32 -> SMGen 351 | mkSMGen s = SMGen (mix32 s) (mixGamma (s + goldenGamma)) 352 | 353 | -- | Initialize 'SMGen' using entropy available on the system (time, ...) 354 | initSMGen :: IO SMGen 355 | initSMGen = fmap mkSMGen initialSeed' 356 | 357 | -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. 358 | newSMGen :: IO SMGen 359 | newSMGen = atomicModifyIORef theSMGen splitSMGen 360 | 361 | theSMGen :: IORef SMGen 362 | theSMGen = unsafePerformIO $ initSMGen >>= newIORef 363 | {-# NOINLINE theSMGen #-} 364 | 365 | initialSeed' :: IO Word32 366 | initialSeed' = do 367 | w64 <- initialSeed 368 | return (fromIntegral (shiftR w64 32) `xor` fromIntegral w64) 369 | -------------------------------------------------------------------------------- /test-hugs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | CABAL=${CABAL:-cabal} 6 | HC=${HC:-ghc} 7 | 8 | # Install cpphs if it is not in path 9 | command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs 10 | 11 | # Regenerate splitmix-hugs 12 | sh make-hugs.sh 13 | find splitmix-hugs 14 | 15 | die() { 16 | echo "TEST FAILED" 17 | exit 1 18 | } 19 | 20 | dotest() { 21 | echo "TEST $2" 22 | echo "$2" | hugs -98 -P:splitmix-hugs -p'> ' "$1" | tee hugs.output 23 | grep "$3" hugs.output || die 24 | } 25 | 26 | # Simple tests 27 | dotest System.Random.SplitMix "nextInteger (-100) 73786976294838206464 (mkSMGen 42)" "(10417309031967932979,SMGen 18209985878117922550 13679457532755275413)" 28 | dotest System.Random.SplitMix32 "nextInteger (-100) 73786976294838206464 (mkSMGen 42)" "(63481308251723623759,SMGen 2735861347 1604540297)" 29 | 30 | dotest System.Random.SplitMix "nextWord64 (mkSMGen 42)" "(1275548033995301424,SMGen 4530528345362647137 13679457532755275413)" 31 | dotest System.Random.SplitMix "nextWord32 (mkSMGen 42)" "(3292324400,SMGen 4530528345362647137 13679457532755275413)" 32 | dotest System.Random.SplitMix "nextTwoWord32 (mkSMGen 42)" "(296986669,3292324400,SMGen 4530528345362647137 13679457532755275413)" 33 | dotest System.Random.SplitMix "nextInt (mkSMGen 42)" "(296986669,SMGen 4530528345362647137 13679457532755275413)" 34 | dotest System.Random.SplitMix "nextDouble (mkSMGen 42)" "(0.069147597478366,SMGen 4530528345362647137 13679457532755275413)" 35 | dotest System.Random.SplitMix "splitSMGen (mkSMGen 42)" "(SMGen 18209985878117922550 13679457532755275413,SMGen 1275548033995301424 10514482549683702313)" 36 | 37 | dotest System.Random.SplitMix "bitmaskWithRejection64 9 (mkSMGen 43)" "(5,SMGen 15756003094639068574 13432527470776545161)" 38 | dotest System.Random.SplitMix "bitmaskWithRejection64' 9 (mkSMGen 44)" "(1,SMGen 3943641360161606062 18105923034897077331)" 39 | 40 | dotest System.Random.SplitMix32 "nextWord64 (mkSMGen 42)" "(5568638952296597105,SMGen 3351673966 1604540297)" 41 | dotest System.Random.SplitMix32 "nextWord32 (mkSMGen 42)" "(1296549791,SMGen 1747133669 1604540297)" 42 | dotest System.Random.SplitMix32 "nextTwoWord32 (mkSMGen 42)" "(1296549791,2315961969,SMGen 3351673966 1604540297)" 43 | dotest System.Random.SplitMix32 "nextInt (mkSMGen 42)" "(1296549791,SMGen 1747133669 1604540297)" 44 | dotest System.Random.SplitMix32 "nextDouble (mkSMGen 42)" "(0.301876522493369,SMGen 3351673966 1604540297)" 45 | dotest System.Random.SplitMix32 "splitSMGen (mkSMGen 42)" "(SMGen 3351673966 1604540297,SMGen 1296549791 306293903)" 46 | 47 | dotest System.Random.SplitMix32 "bitmaskWithRejection64 9 (mkSMGen 43)" "(1,SMGen 261660480 2569677503)" 48 | dotest System.Random.SplitMix32 "bitmaskWithRejection64' 9 (mkSMGen 44)" "(8,SMGen 3882168239 2439575023)" 49 | -------------------------------------------------------------------------------- /tests/Dieharder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Main (main) where 5 | 6 | import Control.Concurrent.QSem 7 | import Control.DeepSeq (force) 8 | import Control.Monad (when) 9 | import Data.Bits (shiftL, (.|.)) 10 | import Data.Char (isSpace) 11 | import Data.List (isInfixOf, unfoldr) 12 | import Data.Maybe (fromMaybe) 13 | import Data.Word (Word64) 14 | import Foreign.C (Errno (..), ePIPE) 15 | import Foreign.Ptr (castPtr) 16 | import GHC.IO.Exception (IOErrorType (..), IOException (..)) 17 | import System.Environment (getArgs) 18 | import System.IO (Handle, hGetContents, stdout) 19 | import Text.Printf (printf) 20 | 21 | import qualified Control.Concurrent.Async as A 22 | import qualified Control.Exception as E 23 | import qualified Data.ByteString as BS 24 | import qualified Data.ByteString.Unsafe as BS (unsafePackCStringLen) 25 | import qualified Data.Vector.Storable.Mutable as MSV 26 | import qualified System.Process as Proc 27 | import qualified System.Random.SplitMix as SM 28 | import qualified System.Random.SplitMix32 as SM32 29 | import qualified System.Random.TF as TF 30 | import qualified System.Random.TF.Gen as TF 31 | import qualified System.Random.TF.Init as TF 32 | 33 | main :: IO () 34 | main = do 35 | args <- getArgs 36 | if null args 37 | then return () 38 | else do 39 | (cmd, runs, conc, seed, test, raw, _help) <- parseArgsIO args $ (,,,,,,) 40 | <$> arg 41 | <*> optDef "-n" 1 42 | <*> optDef "-j" 1 43 | <*> opt "-s" 44 | <*> opt "-d" 45 | <*> flag "-r" 46 | <*> flag "-h" 47 | 48 | let run :: RunType g 49 | run | raw = runRaw 50 | | otherwise = runManaged 51 | 52 | case cmd of 53 | "splitmix" -> do 54 | g <- maybe SM.initSMGen (return . SM.mkSMGen) seed 55 | run test runs conc SM.splitSMGen SM.nextWord64 g 56 | "splitmix32" -> do 57 | g <- maybe SM32.initSMGen (return . SM32.mkSMGen) (fmap fromIntegral seed) 58 | run test runs conc SM32.splitSMGen SM32.nextWord64 g 59 | "tfrandom" -> do 60 | g <- TF.initTFGen 61 | run test runs conc TF.split tfNext64 g 62 | _ -> return () 63 | 64 | tfNext64 :: TF.TFGen -> (Word64, TF.TFGen) 65 | tfNext64 g = 66 | let (w, g') = TF.next g 67 | (w', g'') = TF.next g' 68 | in (fromIntegral w `shiftL` 32 .|. fromIntegral w', g'') 69 | 70 | ------------------------------------------------------------------------------- 71 | -- Dieharder 72 | ------------------------------------------------------------------------------- 73 | 74 | type RunType g = 75 | Maybe Int 76 | -> Int 77 | -> Int 78 | -> (g -> (g, g)) 79 | -> (g -> (Word64, g)) 80 | -> g 81 | -> IO () 82 | 83 | runRaw :: RunType g 84 | runRaw _test _runs _conc split word gen = 85 | generate word split gen stdout 86 | 87 | runManaged :: RunType g 88 | runManaged test runs conc split word gen = do 89 | qsem <- newQSem conc 90 | 91 | rs <- A.forConcurrently (take runs $ unfoldr (Just . split) gen) $ \g -> 92 | E.bracket_ (waitQSem qsem) (signalQSem qsem) $ 93 | dieharder test (generate word split g) 94 | 95 | case mconcat rs of 96 | Result p w f -> do 97 | let total = fromIntegral (p + w + f) :: Double 98 | printf "PASSED %4d %6.02f%%\n" p (fromIntegral p / total * 100) 99 | printf "WEAK %4d %6.02f%%\n" w (fromIntegral w / total * 100) 100 | printf "FAILED %4d %6.02f%%\n" f (fromIntegral f / total * 100) 101 | {-# INLINE runManaged #-} 102 | 103 | dieharder :: Maybe Int -> (Handle -> IO ()) -> IO Result 104 | dieharder test gen = do 105 | let proc = Proc.proc "dieharder" $ ["-g", "200"] ++ maybe ["-a"] (\t -> ["-d", show t]) test 106 | (Just hin, Just hout, _, ph) <- Proc.createProcess proc 107 | { Proc.std_in = Proc.CreatePipe 108 | , Proc.std_out = Proc.CreatePipe 109 | } 110 | 111 | out <- hGetContents hout 112 | waitOut <- A.async $ E.evaluate $ force out 113 | 114 | E.catch (gen hin) $ \e -> case e of 115 | IOError { ioe_type = ResourceVanished , ioe_errno = Just ioe } 116 | | Errno ioe == ePIPE -> return () 117 | _ -> E.throwIO e 118 | 119 | res <- A.wait waitOut 120 | _ <- Proc.waitForProcess ph 121 | 122 | return $ parseOutput res 123 | {-# INLINE dieharder #-} 124 | 125 | parseOutput :: String -> Result 126 | parseOutput = foldMap parseLine . lines where 127 | parseLine l 128 | | any (`isInfixOf` l) doNotUse = mempty 129 | | "PASSED" `isInfixOf` l = Result 1 0 0 130 | | "WEAK" `isInfixOf` l = Result 0 1 0 131 | | "FAILED" `isInfixOf` l = Result 0 1 0 132 | | otherwise = mempty 133 | 134 | doNotUse = ["diehard_opso", "diehard_oqso", "diehard_dna", "diehard_weak"] 135 | 136 | ------------------------------------------------------------------------------- 137 | -- Results 138 | ------------------------------------------------------------------------------- 139 | 140 | data Result = Result 141 | { _passed :: Int 142 | , _weak :: Int 143 | , _failed :: Int 144 | } 145 | deriving Show 146 | 147 | instance Semigroup Result where 148 | Result p w f <> Result p' w' f' = Result (p + p') (w + w') (f + f') 149 | 150 | instance Monoid Result where 151 | mempty = Result 0 0 0 152 | mappend = (<>) 153 | 154 | ------------------------------------------------------------------------------- 155 | -- Writer 156 | ------------------------------------------------------------------------------- 157 | 158 | size :: Int 159 | size = 512 160 | 161 | generate 162 | :: forall g. (g -> (Word64, g)) 163 | -> (g -> (g, g)) 164 | -> g -> Handle -> IO () 165 | generate word split gen0 h = do 166 | vec <- MSV.new size 167 | go gen0 vec 168 | where 169 | go :: g -> MSV.IOVector Word64 -> IO () 170 | go gen vec = do 171 | let (g1, g2) = split gen 172 | write g1 vec 0 173 | MSV.unsafeWith vec $ \ptr -> do 174 | bs <- BS.unsafePackCStringLen (castPtr ptr, size * 8) 175 | BS.hPutStr h bs 176 | go g2 vec 177 | 178 | write :: g -> MSV.IOVector Word64 -> Int -> IO () 179 | write !gen !vec !i = do 180 | let (w64, gen') = word gen 181 | MSV.unsafeWrite vec i w64 182 | when (i < size) $ 183 | write gen' vec (i + 1) 184 | {-# INLINE generate #-} 185 | 186 | ------------------------------------------------------------------------------- 187 | -- readMaybe 188 | ------------------------------------------------------------------------------- 189 | 190 | readEither :: Read a => String -> Either String a 191 | readEither s = 192 | case [ x | (x,rest) <- reads s, all isSpace rest ] of 193 | [x] -> Right x 194 | [] -> Left "Prelude.read: no parse" 195 | _ -> Left "Prelude.read: ambiguous parse" 196 | 197 | readMaybe :: Read a => String -> Maybe a 198 | readMaybe s = case readEither s of 199 | Left _ -> Nothing 200 | Right a -> Just a 201 | 202 | ------------------------------------------------------------------------------- 203 | -- Do it yourself command line parsing 204 | ------------------------------------------------------------------------------- 205 | 206 | -- | 'Parser' is not an 'Alternative', only a *commutative* 'Applicative'. 207 | -- 208 | -- Useful for quick cli parsers, like parametrising tests. 209 | data Parser a where 210 | Pure :: a -> Parser a 211 | Ap :: Arg b -> Parser (b -> a) -> Parser a 212 | 213 | instance Functor Parser where 214 | fmap f (Pure a) = Pure (f a) 215 | fmap f (Ap x y) = Ap x (fmap (f .) y) 216 | 217 | instance Applicative Parser where 218 | pure = Pure 219 | 220 | Pure f <*> z = fmap f z 221 | Ap x y <*> z = Ap x (flip <$> y <*> z) 222 | 223 | data Arg a where 224 | Flag :: String -> Arg Bool 225 | Opt :: String -> (String -> Maybe a) -> Arg (Maybe a) 226 | Arg :: Arg String 227 | 228 | arg :: Parser String 229 | arg = Ap Arg (Pure id) 230 | 231 | flag :: String -> Parser Bool 232 | flag n = Ap (Flag n) (Pure id) 233 | 234 | opt :: Read a => String -> Parser (Maybe a) 235 | opt n = Ap (Opt n readMaybe) (Pure id) 236 | 237 | optDef :: Read a => String -> a -> Parser a 238 | optDef n d = Ap (Opt n readMaybe) (Pure (fromMaybe d)) 239 | 240 | parseArgsIO :: [String] -> Parser a -> IO a 241 | parseArgsIO args p = either fail pure (parseArgs args p) 242 | 243 | parseArgs :: [String] -> Parser a -> Either String a 244 | parseArgs [] p = parserToEither p 245 | parseArgs (x : xs) p = do 246 | (xs', p') <- singleArg p x xs 247 | parseArgs xs' p' 248 | 249 | singleArg :: Parser a -> String -> [String] -> Either String ([String], Parser a) 250 | singleArg (Pure _) x _ = Left $ "Extra argument " ++ x 251 | singleArg (Ap Arg p) x xs 252 | | null x || head x /= '-' = Right (xs, fmap ($ x) p) 253 | | otherwise = fmap2 (Ap Arg) (singleArg p x xs) 254 | singleArg (Ap f@(Flag n) p) x xs 255 | | x == n = Right (xs, fmap ($ True) p) 256 | | otherwise = fmap2 (Ap f) (singleArg p x xs) 257 | singleArg (Ap o@(Opt n r) p) x xs 258 | | x == n = case xs of 259 | [] -> Left $ "Expected an argument for " ++ n 260 | (x' : xs') -> case r x' of 261 | Nothing -> Left $ "Cannot read an argument of " ++ n ++ ": " ++ x' 262 | Just y -> Right (xs', fmap ($ Just y) p) 263 | | otherwise = fmap2 (Ap o) (singleArg p x xs) 264 | 265 | fmap2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 266 | fmap2 = fmap . fmap 267 | 268 | -- | Convert parser to 'Right' if there are only defaultable pieces left. 269 | parserToEither :: Parser a -> Either String a 270 | parserToEither (Pure x) = pure x 271 | parserToEither (Ap (Flag _) p) = parserToEither $ fmap ($ False) p 272 | parserToEither (Ap (Opt _ _) p) = parserToEither $ fmap ($ Nothing) p 273 | parserToEither (Ap Arg _) = Left "argument required" 274 | -------------------------------------------------------------------------------- /tests/Examples.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.HUnit ((@?=)) 4 | 5 | import qualified System.Random.SplitMix32 as SM32 6 | 7 | main :: IO () 8 | main = do 9 | let g = SM32.mkSMGen 42 10 | show g @?= "SMGen 142593372 1604540297" 11 | print g 12 | 13 | let (w32, g') = SM32.nextWord32 g 14 | w32 @?= 1296549791 15 | show g' @?= "SMGen 1747133669 1604540297" 16 | -------------------------------------------------------------------------------- /tests/Initialization.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad (forM_, replicateM) 4 | import Data.List (tails) 5 | import Test.HUnit (assertFailure) 6 | 7 | import qualified System.Random.SplitMix as SM 8 | import qualified System.Random.SplitMix32 as SM32 9 | 10 | main :: IO () 11 | main = do 12 | g64 <- replicateM 10 (fmap show SM.initSMGen) 13 | putStrLn $ unlines g64 14 | forM_ (tails g64) $ \xs' -> case xs' of 15 | [] -> return () 16 | (x:xs) -> 17 | if all (x /=) xs 18 | then return () 19 | else assertFailure "ERROR: duplicate" 20 | 21 | g32 <- replicateM 10 (fmap show SM32.initSMGen) 22 | putStrLn $ unlines g32 23 | forM_ (tails g32) $ \xs' -> case xs' of 24 | [] -> return () 25 | (x:xs) -> 26 | if all (x /=) xs 27 | then return () 28 | else assertFailure "ERROR: duplicate" 29 | -------------------------------------------------------------------------------- /tests/MiniQC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | -- | This QC doesn't shrink :( 3 | module MiniQC where 4 | 5 | import Control.Monad (ap) 6 | import Data.Int (Int32, Int64) 7 | import Data.Word (Word32, Word64) 8 | import Test.Framework.Providers.API (Test, TestName) 9 | import Test.Framework.Providers.HUnit (testCase) 10 | import Test.HUnit (assertFailure) 11 | 12 | import System.Random.SplitMix 13 | 14 | newtype Gen a = Gen { unGen :: SMGen -> a } 15 | deriving (Functor) 16 | 17 | instance Applicative Gen where 18 | pure x = Gen (const x) 19 | (<*>) = ap 20 | 21 | instance Monad Gen where 22 | return = pure 23 | 24 | m >>= k = Gen $ \g -> 25 | let (g1, g2) = splitSMGen g 26 | in unGen (k (unGen m g1)) g2 27 | 28 | class Arbitrary a where 29 | arbitrary :: Gen a 30 | 31 | instance Arbitrary Word32 where 32 | arbitrary = Gen $ \g -> fst (nextWord32 g) 33 | instance Arbitrary Word64 where 34 | arbitrary = Gen $ \g -> fst (nextWord64 g) 35 | instance Arbitrary Int32 where 36 | arbitrary = Gen $ \g -> fromIntegral (fst (nextWord32 g)) 37 | instance Arbitrary Int64 where 38 | arbitrary = Gen $ \g -> fromIntegral (fst (nextWord64 g)) 39 | instance Arbitrary Double where 40 | arbitrary = Gen $ \g -> fst (nextDouble g) 41 | 42 | newtype Property = Property { unProperty :: Gen ([String], Bool) } 43 | 44 | class Testable a where 45 | property :: a -> Property 46 | 47 | instance Testable Property where 48 | property = id 49 | 50 | instance Testable Bool where 51 | property b = Property $ pure ([show b], b) 52 | 53 | instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where 54 | property f = Property $ do 55 | x <- arbitrary 56 | (xs, b) <- unProperty (property (f x)) 57 | return (show x : xs, b) 58 | 59 | forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property 60 | forAllBlind g f = Property $ do 61 | x <- g 62 | (xs, b) <- unProperty (property (f x)) 63 | return ("" : xs, b) 64 | 65 | counterexample :: Testable prop => String -> prop -> Property 66 | counterexample msg prop = Property $ do 67 | (xs, b) <- unProperty (property prop) 68 | return (msg : xs, b) 69 | 70 | testMiniProperty :: Testable prop => TestName -> prop -> Test 71 | testMiniProperty name prop = testCase name $ do 72 | g <- newSMGen 73 | go (100 :: Int) g 74 | where 75 | go n _ | n <= 0 = return () 76 | go n g = do 77 | let (g1, g2) = splitSMGen g 78 | case unGen (unProperty (property prop)) g1 of 79 | (_, True) -> return () 80 | (xs, False) -> assertFailure (unlines (reverse xs)) 81 | go (pred n) g2 82 | -------------------------------------------------------------------------------- /tests/SplitMixPi.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.List (unfoldr, foldl') 4 | import System.Random.SplitMix 5 | 6 | doubles :: SMGen -> [Double] 7 | doubles = unfoldr (Just . nextDouble) 8 | 9 | monteCarloPi :: SMGen -> Double 10 | monteCarloPi = (4 *) . calc . foldl' accum (P 0 0) . take 50000000 . pairs . doubles 11 | where 12 | calc (P n m) = fromIntegral n / fromIntegral m 13 | 14 | pairs (x : y : xs) = (x, y) : pairs xs 15 | pairs _ = [] 16 | 17 | accum (P n m) (x, y) | x * x + y * y >= 1 = P n (m + 1) 18 | | otherwise = P (n + 1) (m + 1) 19 | 20 | data P = P !Int !Int 21 | 22 | main :: IO () 23 | main = do 24 | pi' <- fmap monteCarloPi newSMGen 25 | print (pi :: Double) 26 | print pi' 27 | print (pi - pi') 28 | -------------------------------------------------------------------------------- /tests/SplitMixPi32.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.List (unfoldr, foldl') 4 | import System.Random.SplitMix32 5 | 6 | doubles :: SMGen -> [Float] 7 | doubles = unfoldr (Just . nextFloat) 8 | 9 | monteCarloPi :: SMGen -> Float 10 | monteCarloPi = (4 *) . calc . foldl' accum (P 0 0) . take 50000000 . pairs . doubles 11 | where 12 | calc (P n m) = fromIntegral n / fromIntegral m 13 | 14 | pairs (x : y : xs) = (x, y) : pairs xs 15 | pairs _ = [] 16 | 17 | accum (P n m) (x, y) | x * x + y * y >= 1 = P n (m + 1) 18 | | otherwise = P (n + 1) (m + 1) 19 | 20 | data P = P !Int !Int 21 | 22 | main :: IO () 23 | main = do 24 | pi' <- fmap monteCarloPi newSMGen 25 | print (pi :: Float) 26 | print pi' 27 | print (pi - pi') 28 | -------------------------------------------------------------------------------- /tests/TestU01.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Main (main) where 5 | 6 | import Prelude () 7 | import Prelude.Compat 8 | 9 | import Data.Char (isSpace) 10 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 11 | import Data.Maybe (fromMaybe) 12 | import Data.Word (Word32) 13 | import System.Environment (getArgs) 14 | import System.IO.Unsafe (unsafePerformIO) 15 | 16 | import qualified System.Random.SplitMix as SM64 17 | import qualified System.Random.SplitMix32 as SM32 18 | 19 | ------------------------------------------------------------------------------- 20 | -- SplitMix32 21 | ------------------------------------------------------------------------------- 22 | 23 | sm32ref :: IORef SM32.SMGen 24 | sm32ref = unsafePerformIO $ newIORef $ SM32.mkSMGen 42 25 | {-# NOINLINE sm32ref #-} 26 | 27 | foreign export ccall haskell_splitmix32 :: IO Word32 28 | foreign export ccall haskell_splitmix32_double :: IO Double 29 | 30 | haskell_splitmix32 :: IO Word32 31 | haskell_splitmix32 = do 32 | g <- readIORef sm32ref 33 | let !(w32, g') = SM32.nextWord32 g 34 | writeIORef sm32ref g' 35 | return w32 36 | 37 | haskell_splitmix32_double :: IO Double 38 | haskell_splitmix32_double = do 39 | g <- readIORef sm32ref 40 | let !(d, g') = SM32.nextDouble g 41 | writeIORef sm32ref g' 42 | return d 43 | 44 | ------------------------------------------------------------------------------- 45 | -- SplitMix64 46 | ------------------------------------------------------------------------------- 47 | 48 | sm64ref :: IORef SM64.SMGen 49 | sm64ref = unsafePerformIO $ newIORef $ SM64.mkSMGen 42 50 | {-# NOINLINE sm64ref #-} 51 | 52 | foreign export ccall haskell_splitmix64 :: IO Word32 53 | foreign export ccall haskell_splitmix64_double :: IO Double 54 | 55 | haskell_splitmix64 :: IO Word32 56 | haskell_splitmix64 = do 57 | g <- readIORef sm64ref 58 | let !(w32, g') = SM64.nextWord32 g 59 | writeIORef sm64ref g' 60 | return w32 61 | 62 | haskell_splitmix64_double :: IO Double 63 | haskell_splitmix64_double = do 64 | g <- readIORef sm64ref 65 | let !(d, g') = SM64.nextDouble g 66 | writeIORef sm64ref g' 67 | return d 68 | 69 | ------------------------------------------------------------------------------- 70 | -- Main 71 | ------------------------------------------------------------------------------- 72 | 73 | foreign import ccall "run_testu01" run_testu01_c :: Int -> Int -> IO () 74 | 75 | main :: IO () 76 | main = do 77 | args <- getArgs 78 | (gen, bat) <- parseArgsIO args $ (,) 79 | <$> optDef "-g" SplitMix 80 | <*> optDef "-b" SmallCrush 81 | run_testu01_c (fromEnum gen) (fromEnum bat) 82 | 83 | data Gen 84 | = SplitMixDouble 85 | | SplitMix 86 | | SplitMix32Double 87 | | SplitMix32 88 | | SplitMix32Native 89 | deriving (Read, Enum) 90 | 91 | data Bat 92 | = SmallCrush 93 | | Crush 94 | | BigCrush 95 | | Sample 96 | deriving (Read, Enum) 97 | 98 | ------------------------------------------------------------------------------- 99 | -- readMaybe 100 | ------------------------------------------------------------------------------- 101 | 102 | readEither :: Read a => String -> Either String a 103 | readEither s = 104 | case [ x | (x,rest) <- reads s, all isSpace rest ] of 105 | [x] -> Right x 106 | [] -> Left "Prelude.read: no parse" 107 | _ -> Left "Prelude.read: ambiguous parse" 108 | 109 | readMaybe :: Read a => String -> Maybe a 110 | readMaybe s = case readEither s of 111 | Left _ -> Nothing 112 | Right a -> Just a 113 | 114 | ------------------------------------------------------------------------------- 115 | -- Do it yourself command line parsing 116 | ------------------------------------------------------------------------------- 117 | 118 | -- | 'Parser' is not an 'Alternative', only a *commutative* 'Applicative'. 119 | -- 120 | -- Useful for quick cli parsers, like parametrising tests. 121 | data Parser a where 122 | Pure :: a -> Parser a 123 | Ap :: Arg b -> Parser (b -> a) -> Parser a 124 | 125 | instance Functor Parser where 126 | fmap f (Pure a) = Pure (f a) 127 | fmap f (Ap x y) = Ap x (fmap (f .) y) 128 | 129 | instance Applicative Parser where 130 | pure = Pure 131 | 132 | Pure f <*> z = fmap f z 133 | Ap x y <*> z = Ap x (flip <$> y <*> z) 134 | 135 | data Arg a where 136 | Flag :: String -> Arg Bool 137 | Opt :: String -> (String -> Maybe a) -> Arg (Maybe a) 138 | Arg :: Arg String 139 | 140 | -- arg :: Parser String 141 | -- arg = Ap Arg (Pure id) 142 | -- 143 | -- flag :: String -> Parser Bool 144 | -- flag n = Ap (Flag n) (Pure id) 145 | -- 146 | -- opt :: Read a => String -> Parser (Maybe a) 147 | -- opt n = Ap (Opt n readMaybe) (Pure id) 148 | 149 | optDef :: Read a => String -> a -> Parser a 150 | optDef n d = Ap (Opt n readMaybe) (Pure (fromMaybe d)) 151 | 152 | parseArgsIO :: [String] -> Parser a -> IO a 153 | parseArgsIO args p = either fail pure (parseArgs args p) 154 | 155 | parseArgs :: [String] -> Parser a -> Either String a 156 | parseArgs [] p = parserToEither p 157 | parseArgs (x : xs) p = do 158 | (xs', p') <- singleArg p x xs 159 | parseArgs xs' p' 160 | 161 | singleArg :: Parser a -> String -> [String] -> Either String ([String], Parser a) 162 | singleArg (Pure _) x _ = Left $ "Extra argument " ++ x 163 | singleArg (Ap Arg p) x xs 164 | | null x || head x /= '-' = Right (xs, fmap ($ x) p) 165 | | otherwise = fmap2 (Ap Arg) (singleArg p x xs) 166 | singleArg (Ap f@(Flag n) p) x xs 167 | | x == n = Right (xs, fmap ($ True) p) 168 | | otherwise = fmap2 (Ap f) (singleArg p x xs) 169 | singleArg (Ap o@(Opt n r) p) x xs 170 | | x == n = case xs of 171 | [] -> Left $ "Expected an argument for " ++ n 172 | (x' : xs') -> case r x' of 173 | Nothing -> Left $ "Cannot read an argument of " ++ n ++ ": " ++ x' 174 | Just y -> Right (xs', fmap ($ Just y) p) 175 | | otherwise = fmap2 (Ap o) (singleArg p x xs) 176 | 177 | fmap2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 178 | fmap2 = fmap . fmap 179 | 180 | -- | Convert parser to 'Right' if there are only defaultable pieces left. 181 | parserToEither :: Parser a -> Either String a 182 | parserToEither (Pure x) = pure x 183 | parserToEither (Ap (Flag _) p) = parserToEither $ fmap ($ False) p 184 | parserToEither (Ap (Opt _ _) p) = parserToEither $ fmap ($ Nothing) p 185 | parserToEither (Ap Arg _) = Left "argument required" 186 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.Bits ((.&.)) 4 | import Data.Int (Int64) 5 | import Data.Word (Word64) 6 | import Test.Framework (defaultMain, testGroup) 7 | 8 | import qualified System.Random.SplitMix as SM 9 | import qualified System.Random.SplitMix32 as SM32 10 | 11 | import MiniQC (Arbitrary (..), Gen (..), counterexample, testMiniProperty) 12 | import Uniformity 13 | 14 | main :: IO () 15 | main = defaultMain 16 | [ testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf) 16 17 | , testUniformity "SM64 uniformity" (arbitrary :: Gen Word64) (.&. 0xf0) 16 18 | 19 | , testUniformity "bitmaskWithRejection uniformity" (arbitrary :: Gen Word64mod7) id 7 20 | 21 | , testGroup "nextInteger" 22 | [ testMiniProperty "valid" $ \a b c d seed -> do 23 | let lo' = fromIntegral (a :: Int64) * fromIntegral (b :: Int64) 24 | hi' = fromIntegral (c :: Int64) * fromIntegral (d :: Int64) 25 | 26 | lo = min lo' hi' 27 | hi = max lo' hi' 28 | 29 | let g = SM.mkSMGen seed 30 | (x, _) = SM.nextInteger lo' hi' g 31 | 32 | counterexample (show x) $ lo <= x && x <= hi 33 | 34 | , testMiniProperty "valid small" $ \a b seed -> do 35 | let lo' = fromIntegral (a :: Int64) `rem` 10 36 | hi' = fromIntegral (b :: Int64) `rem` 10 37 | 38 | lo = min lo' hi' 39 | hi = max lo' hi' 40 | 41 | let g = SM.mkSMGen seed 42 | (x, _) = SM.nextInteger lo' hi' g 43 | 44 | counterexample (show x) $ lo <= x && x <= hi 45 | 46 | , testMiniProperty "I1 valid" i1valid 47 | , testUniformity "I1 uniform" arbitrary (\(I1 w) -> w) 15 48 | 49 | , testMiniProperty "I7 valid" i7valid 50 | , testUniformity "I7 uniform" arbitrary (\(I7 w) -> w `mod` 7) 7 51 | ] 52 | 53 | , testGroup "SM bitmaskWithRejection" 54 | [ testMiniProperty "64" $ \w' seed -> do 55 | let w = w' .&. 0xff 56 | let w1 = w + 1 57 | let g = SM.mkSMGen seed 58 | let (x, _) = SM.bitmaskWithRejection64 w1 g 59 | counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1) 60 | , testMiniProperty "64'" $ \w' seed -> do 61 | let w = w' .&. 0xff 62 | let g = SM.mkSMGen seed 63 | let (x, _) = SM.bitmaskWithRejection64' w g 64 | counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w) 65 | , testMiniProperty "32" $ \w' seed -> do 66 | let w = w' .&. 0xff 67 | let u1 = w' 68 | let g = SM.mkSMGen seed 69 | let (x, _) = SM.bitmaskWithRejection32 u1 g 70 | counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1) 71 | , testMiniProperty "32'" $ \w' seed -> do 72 | let w = w' .&. 0xff 73 | let u = w 74 | let g = SM.mkSMGen seed 75 | let (x, _) = SM.bitmaskWithRejection32' u g 76 | counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u) 77 | ] 78 | , testGroup "SM32 bitmaskWithRejection" 79 | [ testMiniProperty "64" $ \w' seed -> do 80 | let w = w' .&. 0xff 81 | let w1 = w + 1 82 | let g = SM32.mkSMGen seed 83 | let (x, _) = SM32.bitmaskWithRejection64 w1 g 84 | counterexample ("64-64 " ++ show x ++ " <= " ++ show w) (x < w1) 85 | , testMiniProperty "64'" $ \w' seed -> do 86 | let w = w' .&. 0xff 87 | let g = SM32.mkSMGen seed 88 | let (x, _) = SM32.bitmaskWithRejection64' w g 89 | counterexample ("64-64 " ++ show x ++ " < " ++ show w) (x <= w) 90 | , testMiniProperty "32" $ \w' seed -> do 91 | let w = w' .&. 0xff 92 | let u1 = w' 93 | let g = SM32.mkSMGen seed 94 | let (x, _) = SM32.bitmaskWithRejection32 u1 g 95 | counterexample ("64-32 " ++ show x ++ " <= " ++ show w) (x < u1) 96 | , testMiniProperty "32'" $ \w' seed -> do 97 | let w = w' .&. 0xff 98 | let u = w 99 | let g = SM32.mkSMGen seed 100 | let (x, _) = SM32.bitmaskWithRejection32' u g 101 | counterexample ("64-32 " ++ show x ++ " < " ++ show w) (x <= u) 102 | ] 103 | ] 104 | 105 | newtype Word64mod7 = W7 Word64 deriving (Eq, Ord, Show) 106 | instance Arbitrary Word64mod7 where 107 | arbitrary = Gen $ \g -> W7 $ fst $ SM.bitmaskWithRejection64' 6 g 108 | 109 | newtype Integer1 = I1 Integer deriving (Eq, Ord, Show) 110 | instance Arbitrary Integer1 where 111 | arbitrary = Gen $ \g -> I1 $ fst $ SM.nextInteger i1min i1max g 112 | 113 | i1min :: Integer 114 | i1min = -7 115 | 116 | i1max :: Integer 117 | i1max = 7 118 | 119 | i1valid :: Integer1 -> Bool 120 | i1valid (I1 i) = i1min <= i && i <= i1max 121 | 122 | newtype Integer7 = I7 Integer deriving (Eq, Ord, Show) 123 | instance Arbitrary Integer7 where 124 | arbitrary = Gen $ \g -> I7 $ fst $ SM.nextInteger i7min i7max g 125 | 126 | i7min :: Integer 127 | i7min = negate two64 128 | 129 | i7max :: Integer 130 | i7max = two64 * 6 + 7 * 1234567 131 | 132 | i7valid :: Integer7 -> Bool 133 | i7valid (I7 i) = i7min <= i && i <= i7max 134 | 135 | two64 :: Integer 136 | two64 = 2 ^ (64 :: Int) 137 | -------------------------------------------------------------------------------- /tests/Uniformity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | -- | Chi-Squared test for uniformity. 5 | module Uniformity (testUniformity) where 6 | 7 | import Data.List (intercalate) 8 | import Data.List (foldl') 9 | import Numeric (showFFloat) 10 | import Numeric.SpecFunctions (incompleteGamma) 11 | import Test.Framework.Providers.API (Test, TestName) 12 | 13 | import qualified Data.Map as Map 14 | 15 | import MiniQC as QC 16 | 17 | -- | \( \lim_{n\to\infty} \mathrm{Pr}(V \le v) = \ldots \) 18 | chiDist 19 | :: Int -- ^ k, categories 20 | -> Double -- ^ v, value 21 | -> Double 22 | chiDist k x = incompleteGamma (0.5 * v) (0.5 * x) where 23 | v = fromIntegral (k - 1) 24 | 25 | -- | When the distribution is uniform, 26 | -- 27 | -- \[ 28 | -- \frac{1}{n} \sum_{s = 1}^k \frac{Y_s^2}{p_s} - n 29 | -- \] 30 | -- 31 | -- simplifies to 32 | -- 33 | -- \[ 34 | -- \frac{k}{n} \sum_{s=1}^k Y_s^2 - n 35 | -- \] 36 | -- 37 | -- when \(p_s = \frac{1}{k} \), i.e. \(k\) is the number of buckets. 38 | -- 39 | calculateV :: Int -> Map.Map k Int -> Double 40 | calculateV k data_ = chiDist k v 41 | where 42 | v = fromIntegral k * fromIntegral sumY2 / fromIntegral n - fromIntegral n 43 | V2 n sumY2 = foldl' sumF (V2 0 0) (Map.elems data_) where 44 | sumF (V2 m m2) x = V2 (m + x) (m2 + x * x) 45 | 46 | -- Strict pair of 'Int's, used as an accumulator. 47 | data V2 = V2 !Int !Int 48 | 49 | countStream :: Ord a => Stream a -> Int -> Map.Map a Int 50 | countStream = go Map.empty where 51 | go !acc s n 52 | | n <= 0 = acc 53 | | otherwise = case s of 54 | x :> xs -> go (Map.insertWith (+) x 1 acc) xs (pred n) 55 | 56 | testUniformityRaw :: forall a. (Ord a, Show a) => Int -> Stream a -> Either String Double 57 | testUniformityRaw k s 58 | | Map.size m > k = Left $ "Got more elements (" ++ show (Map.size m, take 5 $ Map.keys m) ++ " than expected (" ++ show k ++ ")" 59 | | p > 0.999999 = Left $ 60 | "Too impropabable p-value: " ++ show p ++ "\n" ++ table 61 | [ [ show x, showFFloat (Just 3) (fromIntegral y / fromIntegral n :: Double) "" ] 62 | | (x, y) <- take 20 $ Map.toList m 63 | ] 64 | | otherwise = Right p 65 | where 66 | -- each bucket to have roughly 128 elements 67 | n :: Int 68 | n = k * 128 69 | 70 | -- buckets from the stream 71 | m :: Map.Map a Int 72 | m = countStream s n 73 | 74 | -- calculate chi-squared value 75 | p :: Double 76 | p = calculateV k m 77 | 78 | testUniformityQC :: (Ord a, Show a) => Int -> Stream a -> QC.Property 79 | testUniformityQC k s = case testUniformityRaw k s of 80 | Left err -> QC.counterexample err False 81 | Right _ -> QC.property True 82 | 83 | -- | Test that generator produces values uniformly. 84 | -- 85 | -- The size is scaled to be at least 20. 86 | -- 87 | testUniformity 88 | :: forall a b. (Ord b, Show b) 89 | => TestName 90 | -> QC.Gen a -- ^ Generator to test 91 | -> (a -> b) -- ^ Partitioning function 92 | -> Int -- ^ Number of partittions 93 | -> Test 94 | testUniformity name gen f k = QC.testMiniProperty name 95 | $ QC.forAllBlind (streamGen gen) 96 | $ testUniformityQC k . fmap f 97 | 98 | ------------------------------------------------------------------------------- 99 | -- Infinite stream 100 | ------------------------------------------------------------------------------- 101 | 102 | data Stream a = a :> Stream a deriving (Functor) 103 | infixr 5 :> 104 | 105 | streamGen :: QC.Gen a -> QC.Gen (Stream a) 106 | streamGen g = gs where 107 | gs = do 108 | x <- g 109 | xs <- gs 110 | return (x :> xs) 111 | 112 | ------------------------------------------------------------------------------- 113 | -- Table 114 | ------------------------------------------------------------------------------- 115 | 116 | table :: [[String]] -> String 117 | table cells = unlines rows 118 | where 119 | cols :: Int 120 | rowWidths :: [Int] 121 | rows :: [String] 122 | 123 | (cols, rowWidths, rows) = foldr go (0, repeat 0, []) cells 124 | 125 | go :: [String] -> (Int, [Int], [String]) -> (Int, [Int], [String]) 126 | go xs (c, w, yss) = 127 | ( max c (length xs) 128 | , zipWith max w (map length xs ++ repeat 0) 129 | , intercalate " " (take cols (zipWith fill xs rowWidths)) 130 | : yss 131 | ) 132 | 133 | fill :: String -> Int -> String 134 | fill s n = s ++ replicate (n - length s) ' ' 135 | -------------------------------------------------------------------------------- /tests/cbits/testu01.c: -------------------------------------------------------------------------------- 1 | #include "TestU01.h" 2 | 3 | #include 4 | 5 | /* Utilities */ 6 | 7 | inline unsigned int popcount32(uint32_t i) { 8 | i = i - ((i >> 1) & 0x55555555); 9 | i = (i & 0x33333333) + ((i >> 2) & 0x33333333); 10 | return (((i + (i >> 4)) & 0xF0F0F0F) * 0x1010101) >> 24; 11 | } 12 | 13 | inline uint64_t rotl64(uint64_t value, unsigned int count) { 14 | return value << count | value >> (64 - count); 15 | } 16 | 17 | /* For comparison, SplitMix32 generator in C */ 18 | #define GOLDEN_GAMMA 0x9e3779b9U 19 | 20 | static uint32_t seed = 0; 21 | static uint32_t gamma = 0; 22 | 23 | uint32_t mix32(uint32_t z) { 24 | z = (z ^ (z >> 16)) * 0x85ebca6b; 25 | z = (z ^ (z >> 13)) * 0xc2b2ae35; 26 | z = (z ^ (z >> 16)); 27 | return z; 28 | } 29 | 30 | uint32_t mix32gamma(uint32_t z) { 31 | z = (z ^ (z >> 16)) * 0x69ad6ccbU; 32 | z = (z ^ (z >> 13)) * 0xcd9ab5b3U; 33 | z = (z ^ (z >> 16)); 34 | return z; 35 | } 36 | 37 | void splitmix32_init(uint32_t s) { 38 | seed = mix32(s); 39 | gamma = mix32gamma(s + GOLDEN_GAMMA) | 0x1; 40 | if (popcount32(gamma ^ (gamma >> 1)) < 12) { 41 | gamma = gamma ^ 0xaaaaaaaa; 42 | } 43 | } 44 | 45 | unsigned int splitmix32() { 46 | seed = seed + gamma; 47 | return mix32(seed); 48 | } 49 | 50 | /* Exported from Haskell */ 51 | uint32_t haskell_splitmix32(); 52 | 53 | unsigned int exported_splitmix32() { 54 | return haskell_splitmix32(); 55 | } 56 | 57 | uint32_t haskell_splitmix64(); 58 | 59 | unsigned int exported_splitmix64() { 60 | return haskell_splitmix64(); 61 | } 62 | 63 | double haskell_splitmix64_double(); 64 | double haskell_splitmix32_double(); 65 | 66 | /* Test suite */ 67 | 68 | int run_testu01(int gen_k, int bat_k) { 69 | /* Create TestU01 PRNG object for our generator */ 70 | unsigned int (*funcBits)() = NULL; 71 | double (*func01)() = NULL; 72 | unif01_Gen* gen = NULL; 73 | 74 | switch (gen_k) { 75 | case 0: 76 | func01 = haskell_splitmix64_double; 77 | gen = unif01_CreateExternGen01 ("SplitMix (Double)", haskell_splitmix64_double); 78 | break; 79 | 80 | case 1: 81 | funcBits = exported_splitmix64; 82 | gen = unif01_CreateExternGenBits("SplitMix (low 32bit)", exported_splitmix64); 83 | break; 84 | 85 | case 2: 86 | func01 = haskell_splitmix32_double; 87 | gen = unif01_CreateExternGen01("SplitMix32 (Double)", haskell_splitmix32_double); 88 | break; 89 | 90 | case 3: 91 | funcBits = exported_splitmix32; 92 | gen = unif01_CreateExternGenBits("SplitMix32", exported_splitmix32); 93 | break; 94 | 95 | default: 96 | splitmix32_init(42); 97 | printf("Initial state: %u %u\n", seed, gamma); 98 | 99 | funcBits = splitmix32; 100 | gen = unif01_CreateExternGenBits("SplitMix32 (C implementation)", splitmix32); 101 | } 102 | 103 | /* Run the tests. */ 104 | switch (bat_k) { 105 | case 0: 106 | bbattery_SmallCrush(gen); 107 | break; 108 | 109 | case 1: 110 | bbattery_Crush(gen); 111 | break; 112 | 113 | case 2: 114 | bbattery_BigCrush(gen); 115 | break; 116 | 117 | default: 118 | if (funcBits != NULL) { 119 | for (int i = 0; i < 32; i++) { 120 | printf("%x\n", funcBits()); 121 | } 122 | } 123 | 124 | if (func01 != NULL) { 125 | for (int i = 0; i < 32; i++) { 126 | printf("%.09lf\n", func01()); 127 | } 128 | } 129 | } 130 | 131 | if (funcBits != NULL) { 132 | unif01_DeleteExternGenBits(gen); 133 | } else if (func01 != NULL) { 134 | unif01_DeleteExternGen01(gen); 135 | } 136 | 137 | return 0; 138 | } 139 | -------------------------------------------------------------------------------- /tools/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /tools/splitmix-tools.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: splitmix-tools 3 | version: 0 4 | synopsis: Tools for splitmix development 5 | description: 6 | * generate-mix32 generates JavaScript for SplitMix32 GHCJS implementation. 7 | 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | maintainer: Oleg Grenrus 11 | category: System, Random 12 | 13 | source-repository head 14 | type: git 15 | location: https://github.com/phadej/splitmix.git 16 | 17 | library 18 | default-language: Haskell2010 19 | hs-source-dirs: src 20 | build-depends: 21 | , base >=4.3 && <5 22 | , transformers 23 | 24 | exposed-modules: Dummy 25 | 26 | test-suite generate-mix32 27 | type: exitcode-stdio-1.0 28 | default-language: Haskell2010 29 | ghc-options: -Wall 30 | hs-source-dirs: src 31 | main-is: GenMix32.hs 32 | build-depends: 33 | , base 34 | , base-compat ^>=0.11.1 35 | , transformers 36 | 37 | executable splitmix-avalanche 38 | default-language: Haskell2010 39 | ghc-options: -Wall -threaded -rtsopts 40 | hs-source-dirs: src 41 | main-is: Avalanche.hs 42 | other-modules: SimulatedAnnealing 43 | build-depends: 44 | , base 45 | , splitmix 46 | , vector >=0.11.0.0 && <0.13 47 | -------------------------------------------------------------------------------- /tools/src/Avalanche.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main (main) where 3 | 4 | import Data.Bits 5 | import System.Random.SplitMix 6 | import Control.Monad (when) 7 | import Data.Word 8 | import Data.List (unfoldr) 9 | import Data.Foldable (for_) 10 | import Control.Monad.ST 11 | import Text.Printf 12 | 13 | import qualified Data.Vector.Unboxed as U 14 | import qualified Data.Vector.Unboxed.Mutable as MU 15 | 16 | import SimulatedAnnealing 17 | 18 | -- | 19 | -- 20 | -- @ 21 | -- uint32_t murmurmix32( uint32_t h ) 22 | -- { 23 | -- h ^= h >> 16; 24 | -- h *= 0x85ebca6b; 25 | -- h ^= h >> 13; 26 | -- h *= 0xc2b2ae35; 27 | -- h ^= h >> 16; 28 | -- 29 | -- return h; 30 | -- } 31 | -- @ 32 | -- 33 | murmurmix32 :: Word32 -> Word32 34 | murmurmix32 x0 = 35 | let x1 = x0 `xor` (x0 `shiftR` 16) 36 | x2 = x1 * 0x85ebca6b 37 | x3 = x2 `xor` (x1 `shiftR` 13) 38 | x4 = x3 * 0xc2b2ae35 39 | x5 = x4 `xor` (x4 `shiftR` 16) 40 | in x5 41 | 42 | paramMurMurMix 43 | :: Int -> Int -> Int 44 | -> Word32 -> Word32 45 | -> Word32 -> Word32 46 | paramMurMurMix s1 s2 s3 m1 m2 x0 = 47 | let x1 = x0 `xor` (x0 `shiftR` s1) 48 | x2 = x1 * m1 49 | x3 = x2 `xor` (x1 `shiftR` s2) 50 | x4 = x3 * m2 51 | x5 = x4 `xor` (x4 `shiftR` s3) 52 | in x5 53 | 54 | avalancheStep :: (Word32 -> Word32) -> U.MVector s Word32 -> Word32 -> ST s () 55 | avalancheStep f vec x = 56 | for_ [0..31] $ \i -> do 57 | let y = x `xor` mask i 58 | y' = f y 59 | 60 | for_ [0..31] $ \j -> 61 | when (((x' `xor` y') .&. mask j) /= 0) $ 62 | MU.unsafeModify vec succ (i * 32 + j) 63 | where 64 | x' = f x 65 | mask k = 1 `shiftL` k 66 | 67 | -- | Calculate avalanche energy for given function. 68 | avalanche :: U.Vector Word32 -> (Word32 -> Word32) -> Double 69 | avalanche inputs f = 70 | let matrix = runST $ do 71 | vec <- MU.replicate (32 * 32) (0 :: Word32) 72 | 73 | U.foldM_ (\_ -> avalancheStep f vec) () inputs 74 | 75 | U.freeze vec 76 | 77 | matrix1 = U.map (\n -> sq $ (fromIntegral n - halfsize) / size) matrix 78 | matrix2 = U.sum matrix1 79 | 80 | in matrix2 / (32 * 32) * 4.0 81 | 82 | where 83 | sq x = x * x 84 | 85 | size :: Double 86 | size = fromIntegral $ U.length inputs 87 | 88 | halfsize :: Double 89 | halfsize = size /2 90 | 91 | getInput :: Int -> U.Vector Word32 92 | getInput size = 93 | U.fromList $ map fromIntegral $ take size $ unfoldr (Just . nextWord64) smgen 94 | where 95 | smgen = mkSMGen 0xdeadbeef 96 | 97 | main :: IO () 98 | main = do 99 | -- test avalanche of murmurmix32 100 | do 101 | let input = getInput $ 1024 * 1024 102 | print $ avalanche input murmurmix32 103 | 104 | -- test avalanche of paramMurMurMix 105 | do 106 | let input = getInput $ 1024 * 1024 107 | print $ avalanche input $ paramMurMurMix 16 13 16 0x69ad6ccb 0xcd9ab5b3 108 | 109 | -- test avalanche of bad paramMurMurMix 110 | do 111 | let input = getInput $ 1024 * 1024 112 | print $ avalanche input $ paramMurMurMix 16 13 16 0x00000001 0x00010000 113 | 114 | -- simulated-annealing 115 | -- https://en.wikipedia.org/wiki/Simulated_annealing 116 | optimise (mkSMGen 0xfeedbacc) 0 0 117 | -- optimise (mkSMGen 0xfeedbacc) 0xa9b1c34d 0x6ca4ba2d 118 | 119 | -- | MurMurMixer parameters. 120 | data MurMurData = MurMurData !Int !Int !Int !Word32 !Word32 121 | 122 | instance Pretty MurMurData where 123 | pretty (MurMurData _ _ _ m1 m2) = printf "0x%08x 0x%08x" m1 m2 124 | 125 | optimise :: SMGen -> Word32 -> Word32 -> IO () 126 | optimise initGen i1 i2 = do 127 | _ <- simulatedAnnealing problem initGen (MurMurData 16 13 16 i1 i2) genStep 128 | return () 129 | where 130 | problem :: Problem MurMurData Int 131 | problem = Problem 132 | { pPerturb = perturb 133 | , pEnergy = energy 134 | } 135 | where 136 | energy :: MurMurData -> Double 137 | energy (MurMurData s1 s2 s3 m1 m2) = 138 | avalanche input $ paramMurMurMix s1 s2 s3 m1 m2 139 | 140 | input = getInput $ 1024 * 256 141 | 142 | perturb :: MurMurData -> Int -> MurMurData 143 | perturb (MurMurData s1 s2 s3 m1 m2) w = MurMurData s1 s2 s3 m1' m2' 144 | where 145 | (m1', m2') | w >= 32 = (m1 `xor` mask (w - 32), m2) 146 | | otherwise = (m1, m2 `xor` mask w) 147 | 148 | genStep :: SMGen -> Int 149 | genStep g = 150 | let (w64, _) = nextWord64 g 151 | in fromIntegral $ w64 `mod` 64 152 | 153 | mask :: Int -> Word32 154 | mask k = 1 `shiftL` k 155 | 156 | -------------------------------------------------------------------------------- /tools/src/Dummy.hs: -------------------------------------------------------------------------------- 1 | module Dummy () where 2 | -------------------------------------------------------------------------------- /tools/src/GenMix32.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- cabal v2-build generate-mix32 && $(cabal-plan list-bin generate-mix32) 3 | module Main (main) where 4 | 5 | import Prelude () 6 | import Prelude.Compat 7 | 8 | import Control.Applicative ((<|>)) 9 | import Control.Monad (ap, liftM) 10 | import Control.Monad.Trans.State (State, evalState, get, put) 11 | import Data.Bits (shiftL, shiftR, xor, (.&.)) 12 | import Data.Foldable (toList) 13 | import Data.Maybe (isNothing) 14 | import Data.Functor.Classes 15 | import Data.Int (Int32) 16 | import Data.Traversable (foldMapDefault) 17 | import Data.Word (Word32) 18 | import Text.Printf (printf) 19 | 20 | ------------------------------------------------------------------------------- 21 | -- Expr 22 | ------------------------------------------------------------------------------- 23 | 24 | data Expr a 25 | -- Combinators we use in the expression 26 | = V a 27 | | K Word32 28 | | ShiftR (Expr a) Int 29 | | Xor (Expr a) (Expr a) 30 | | Mult (Expr a) (Expr a) 31 | 32 | -- Other combinators 33 | | ShiftL (Expr a) Int 34 | | Plus (Expr a) (Expr a) 35 | 36 | | Trunc16 (Expr a) 37 | | Trunc32 (Expr a) 38 | 39 | | Let (Expr a) (Expr (Maybe a)) 40 | 41 | ------------------------------------------------------------------------------- 42 | -- Instances 43 | ------------------------------------------------------------------------------- 44 | 45 | instance Foldable Expr where 46 | foldMap = foldMapDefault 47 | 48 | instance Traversable Expr where 49 | traverse f (V a) = V <$> f a 50 | traverse _ (K x) = pure (K x) 51 | 52 | traverse f (ShiftR x n) = ShiftR <$> traverse f x <*> pure n 53 | traverse f (Xor x y) = Xor <$> traverse f x <*> traverse f y 54 | traverse f (Mult x y) = Mult <$> traverse f x <*> traverse f y 55 | 56 | traverse f (ShiftL x n) = ShiftR <$> traverse f x <*> pure n 57 | traverse f (Plus x y) = Plus <$> traverse f x <*> traverse f y 58 | 59 | traverse f (Trunc16 x) = Trunc16 <$> traverse f x 60 | traverse f (Trunc32 x) = Trunc32 <$> traverse f x 61 | 62 | traverse f (Let x y) = Let <$> traverse f x <*> traverse (traverse f) y 63 | 64 | instance Eq1 Expr where 65 | liftEq eq (V x) (V x') = eq x x' 66 | liftEq _ (K x) (K x') = x == x' 67 | 68 | liftEq eq (ShiftR x y) (ShiftR x' y') = liftEq eq x x' && y == y' 69 | liftEq eq (Xor x y) (Xor x' y') = liftEq eq x x' && liftEq eq y y' 70 | liftEq eq (Mult x y) (Mult x' y') = liftEq eq x x' && liftEq eq y y' 71 | 72 | liftEq eq (ShiftL x y) (ShiftL x' y') = liftEq eq x x' && y == y' 73 | liftEq eq (Plus x y) (Plus x' y') = liftEq eq x x' && liftEq eq y y' 74 | 75 | liftEq eq (Trunc16 x) (Trunc16 x') = liftEq eq x x' 76 | liftEq eq (Trunc32 x) (Trunc32 x') = liftEq eq x x' 77 | 78 | liftEq eq (Let x y) (Let x' y') = liftEq eq x x' && liftEq (liftEq eq) y y' 79 | 80 | liftEq _ _ _ = False 81 | 82 | instance Eq a => Eq (Expr a) where 83 | (==) = eq1 84 | 85 | instance Show1 Expr where 86 | liftShowsPrec sp _ d (V x) = showsUnaryWith 87 | sp 88 | "V" d x 89 | liftShowsPrec _ _ d (K x) = showsUnaryWith 90 | showsPrec 91 | "K" d x 92 | 93 | liftShowsPrec sp sl d (ShiftR x y) = showsBinaryWith 94 | (liftShowsPrec sp sl) 95 | showsPrec 96 | "ShiftR" d x y 97 | liftShowsPrec sp sl d (Xor x y) = showsBinaryWith 98 | (liftShowsPrec sp sl) 99 | (liftShowsPrec sp sl) 100 | "Xor" d x y 101 | liftShowsPrec sp sl d (Mult x y) = showsBinaryWith 102 | (liftShowsPrec sp sl) 103 | (liftShowsPrec sp sl) 104 | "Mult" d x y 105 | 106 | liftShowsPrec sp sl d (ShiftL x y) = showsBinaryWith 107 | (liftShowsPrec sp sl) 108 | showsPrec 109 | "ShiftL" d x y 110 | liftShowsPrec sp sl d (Plus x y) = showsBinaryWith 111 | (liftShowsPrec sp sl) 112 | (liftShowsPrec sp sl) 113 | "Plus" d x y 114 | 115 | liftShowsPrec sp sl d (Trunc16 x) = showsUnaryWith 116 | (liftShowsPrec sp sl) 117 | "Trunc16" d x 118 | 119 | liftShowsPrec sp sl d (Trunc32 x) = showsUnaryWith 120 | (liftShowsPrec sp sl) 121 | "Trunc32" d x 122 | 123 | liftShowsPrec sp sl d (Let x y) = showsBinaryWith 124 | (liftShowsPrec sp sl) 125 | (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) 126 | "Let" d x y 127 | 128 | instance Show a => Show (Expr a) where 129 | showsPrec = showsPrec1 130 | 131 | ------------------------------------------------------------------------------- 132 | -- Main 133 | ------------------------------------------------------------------------------- 134 | 135 | main :: IO () 136 | main = do 137 | putStrLn "mix32" 138 | main' (mix32 "$1") 139 | putStrLn "" 140 | putStrLn "mix32variant13" 141 | main' (mix32variant13 "$1") 142 | where 143 | main' e = do 144 | putStrLn "==============================================" 145 | let v = eval (const 42) e 146 | print v 147 | print (fromIntegral v :: Int32) 148 | putStrLn $ pretty $ "42" <$ e 149 | 150 | let e1 = compile e 151 | let v1 = eval (const 42) e1 152 | print v1 153 | print (fromIntegral v1 :: Int32) 154 | putStrLn $ pretty $ "42" <$ e1 155 | 156 | let e2 = optimise e1 157 | let v2 = eval (const 42) e2 158 | print v2 159 | print (fromIntegral v2 :: Int32) 160 | print e2 161 | putStrLn "==============================================" 162 | putStrLn $ pretty $ "42" <$ e2 163 | putStrLn "----------------------------------------------" 164 | putStrLn $ pretty $ "$1" <$ e2 165 | putStrLn "==============================================" 166 | 167 | ------------------------------------------------------------------------------- 168 | -- Mixer helpers 169 | ------------------------------------------------------------------------------- 170 | 171 | shiftXor :: Int -> Expr ctx -> Expr ctx 172 | shiftXor n w = 173 | Let w $ V Nothing `Xor` (V Nothing `ShiftR` n) 174 | 175 | shiftXorMultiply :: Int -> Expr ctx -> Expr ctx -> Expr ctx 176 | shiftXorMultiply n k w = shiftXor n w `Mult` k 177 | 178 | ------------------------------------------------------------------------------- 179 | -- Mixers 180 | ------------------------------------------------------------------------------- 181 | 182 | mix32 :: a -> Expr a 183 | mix32 z0 = 184 | let z1 = shiftXorMultiply 16 (K 0x85ebca6b) (V z0) 185 | z2 = shiftXorMultiply 13 (K 0xc2b2ae35) z1 186 | z3 = shiftXor 16 z2 187 | in z3 188 | 189 | mix32variant13 :: a -> Expr a 190 | mix32variant13 z0 = 191 | -- See avalanche "executable" 192 | let z1 = shiftXorMultiply 16 (K 0x69ad6ccb) (V z0) 193 | z2 = shiftXorMultiply 13 (K 0xcd9ab5b3) z1 194 | z3 = shiftXor 16 z2 195 | in z3 196 | 197 | ------------------------------------------------------------------------------- 198 | -- Expr stuff 199 | ------------------------------------------------------------------------------- 200 | 201 | instance Functor Expr where 202 | fmap = liftM 203 | 204 | instance Applicative Expr where 205 | pure = return 206 | (<*>) = ap 207 | 208 | instance Monad Expr where 209 | return = V 210 | 211 | V a >>= k = k a 212 | K w >>= _ = K w 213 | ShiftR x n >>= k = ShiftR (x >>= k) n 214 | Xor x y >>= k = Xor (x >>= k) (y >>= k) 215 | Mult x y >>= k = Mult (x >>= k) (y >>= k) 216 | 217 | ShiftL x n >>= k = ShiftL (x >>= k) n 218 | Plus x y >>= k = Plus (x >>= k) (y >>= k) 219 | Trunc16 x >>= k = Trunc16 (x >>= k) 220 | Trunc32 x >>= k = Trunc32 (x >>= k) 221 | 222 | Let e v >>= k = Let (e >>= k) (v >>== k) 223 | 224 | (>>==) :: Expr (Maybe a) -> (a -> Expr b) -> Expr (Maybe b) 225 | e >>== k = e >>= maybe (V Nothing) (lift . k) 226 | 227 | instantiate :: Expr a -> Expr (Maybe a) -> Expr a 228 | instantiate v e = e >>= maybe v V 229 | 230 | lift :: Expr a -> Expr (Maybe a) 231 | lift = fmap Just 232 | 233 | ------------------------------------------------------------------------------- 234 | -- Evaluation 235 | ------------------------------------------------------------------------------- 236 | 237 | eval :: (a -> Word32) -> Expr a -> Word32 238 | eval ctx = go where 239 | go (V a) = ctx a 240 | go (K w) = w 241 | go (ShiftR x n) = go x `shiftR` n 242 | go (Xor x y) = go x `xor` go y 243 | go (Mult x y) = go x * go y 244 | 245 | go (ShiftL x n) = go x `shiftL` n 246 | go (Plus x y) = go x + go y 247 | go (Trunc16 x) = go x .&. 0xffff 248 | go (Trunc32 x) = go x .&. 0xffffffff 249 | 250 | go (Let e f) = go $ instantiate e f 251 | 252 | ------------------------------------------------------------------------------- 253 | -- Pretty 254 | ------------------------------------------------------------------------------- 255 | 256 | data S = String :< S 257 | 258 | names :: S 259 | names = go (0 :: Int) 260 | where 261 | go n = ("x" ++ show n) :< go (succ n) 262 | 263 | pretty :: Expr String -> String 264 | pretty e = evalState (final e) names where 265 | -- JavaScript precedence 266 | -- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence 267 | final :: Expr String -> State S String 268 | final x = do 269 | x' <- go 8 x 270 | return $ x' ++ " | 0" 271 | 272 | go :: Int -> Expr String -> State S String 273 | go _ (V n) = return n 274 | go _ (K w) = return $ printf "0x%08x" w 275 | go d (ShiftR x n) = parens (d > 12) $ do 276 | x' <- go 13 x 277 | return $ x' ++ " >>> " ++ show n 278 | go d (Xor x y) = parens (d > 8) $ do 279 | x' <- go 9 x 280 | y' <- go 8 y 281 | return $ x' ++ " ^ " ++ y' 282 | go d (Mult x y) = parens (d > 14) $ do 283 | x' <- go 15 x 284 | y' <- go 14 y 285 | return $ x' ++ " * " ++ y' 286 | 287 | go d (ShiftL x n) = parens (d > 12) $ do 288 | x' <- go 13 x 289 | return $ x' ++ " << " ++ show n 290 | go d (Plus x y) = parens (d > 13) $ do 291 | x' <- go 14 x 292 | y' <- go 13 y 293 | return $ x' ++ " + " ++ y' 294 | go d (Trunc16 x) = parens (d > 9) $ do 295 | x' <- go 10 x 296 | return $ x' ++ " & 0xffff" 297 | go d (Trunc32 x) = parens (d > 9) $ do 298 | x' <- go 10 x 299 | return $ x' ++ " & 0xffffffff" 300 | 301 | go d (Let x y) = parens (d > 1) $ do 302 | n :< ns <- get 303 | put ns 304 | x' <- go 2 x 305 | y' <- go 1 $ instantiate (V n) y 306 | return $ n ++ " = " ++ x' ++ " , " ++ y' 307 | 308 | parens :: Functor f => Bool -> f String -> f String 309 | parens False = id 310 | parens True = fmap $ \x -> "(" ++ x ++ ")" 311 | 312 | ------------------------------------------------------------------------------- 313 | -- Compile 314 | ------------------------------------------------------------------------------- 315 | 316 | compile :: Expr a -> Expr a 317 | compile (V a) = V a 318 | compile (K w) = K w 319 | compile (ShiftR e n) = ShiftR (compile e) n 320 | compile (Xor x y) = Xor (compile x) (compile y) 321 | compile (Mult xy uv) 322 | = Let (compile xy) 323 | $ Let (Trunc16 $ ShiftR (V Nothing) 16) 324 | $ Let (Trunc16 $ V $ Just Nothing) 325 | $ Let (lift $ lift $ lift $ compile uv) 326 | $ Let (Trunc16 $ ShiftR (V Nothing) 16) 327 | $ Let (Trunc16 $ V $ Just Nothing) 328 | $ ShiftL (Trunc16 $ Mult x v `Plus` Mult y u) 16 `Plus` Mult y v 329 | where 330 | x = V $ Just $ Just $ Just $ Just Nothing 331 | y = V $ Just $ Just $ Just Nothing 332 | u = V $ Just Nothing 333 | v = V Nothing 334 | 335 | compile (Let x n) = Let (compile x) (compile n) 336 | 337 | compile e = e 338 | 339 | ------------------------------------------------------------------------------- 340 | -- Optimise 341 | ------------------------------------------------------------------------------- 342 | 343 | optimise :: Eq a => Expr a -> Expr a 344 | optimise = go (10 :: Int) where 345 | go n x | n < 0 = x 346 | | otherwise = opt (go (pred n) x) 347 | 348 | opt = rew -- . cse 349 | rew = rewrite $ \x -> inline x <|> constFold x <|> letFloat x -- <|> push x 350 | 351 | ------------------------------------------------------------------------------- 352 | -- Rewrites 353 | ------------------------------------------------------------------------------- 354 | 355 | rewrite :: (forall x. Expr x -> Maybe (Expr x)) -> Expr a -> Expr a 356 | rewrite f = go 357 | where 358 | g :: forall y. Expr y -> Expr y 359 | g x = maybe x g (f x) 360 | 361 | go :: forall y. Expr y -> Expr y 362 | go e@(V _) = g e 363 | go e@(K _) = g e 364 | go (ShiftR x n) = g (ShiftR (go x) n) 365 | go (Xor x y) = g (Xor (go x) (go y)) 366 | go (Mult x y) = g (Mult (go x) (go y)) 367 | 368 | go (ShiftL x n) = g (ShiftL (go x) n) 369 | go (Plus x y) = g (Plus (go x) (go y)) 370 | 371 | go (Trunc16 x) = g (Trunc16 (go x)) 372 | go (Trunc32 x) = g (Trunc32 (go x)) 373 | 374 | go (Let x y) = g (Let (go x) (go y)) 375 | 376 | constFold :: Expr a -> Maybe (Expr a) 377 | constFold (ShiftR (K w32) n) = Just (K (w32 `shiftR` n)) 378 | constFold (Trunc16 (K w32)) = Just (K (w32 .&. 0xffff)) 379 | constFold _ = Nothing 380 | 381 | inline :: Expr a -> Maybe (Expr a) 382 | inline (Let (K w32) e) = Just (instantiate (K w32) e) -- let x = 42 in ... 383 | inline (Let (V n) e) = Just (instantiate (V n) e) -- let x = y in ... 384 | inline (Let x e) = case bindings of 385 | [] -> traverse (const Nothing) e -- unused binding 386 | [_] -> Just $ instantiate x e -- single use 387 | _ -> Nothing 388 | where 389 | bindings = filter isNothing $ toList e 390 | inline _ = Nothing 391 | 392 | -- let n = (let m = x in y) in z 393 | -- ----------------------------- 394 | -- let m = x in let n = y in z 395 | -- 396 | letFloat :: Expr a -> Maybe (Expr a) 397 | letFloat (Let (Let x y) z) = Just 398 | $ Let x 399 | $ Let y $ fmap (fmap Just) z 400 | letFloat _ = Nothing 401 | 402 | 403 | _push :: Expr a -> Maybe (Expr a) 404 | _push = push 405 | 406 | push :: Expr a -> Maybe (Expr a) 407 | push (Trunc16 (Let x y)) = Just $ Let x (Trunc16 y) 408 | push (ShiftR (Let x y) n) = Just $ Let x (ShiftR y n) 409 | push (ShiftL (Let x y) n) = Just $ Let x (ShiftL y n) 410 | 411 | push (Mult (Let x y) z) = Just $ Let x (Mult y (lift z)) 412 | push (Plus (Let x y) z) = Just $ Let x (Plus y (lift z)) 413 | push (Xor (Let x y) z) = Just $ Let x (Xor y (lift z)) 414 | 415 | push (Mult x (Let y z)) = Just $ Let y (Mult (lift x) z) 416 | push (Plus x (Let y z)) = Just $ Let y (Plus (lift x) z) 417 | push (Xor x (Let y z)) = Just $ Let y (Xor (lift x) z) 418 | 419 | push _ = Nothing 420 | 421 | ------------------------------------------------------------------------------- 422 | -- CSE 423 | ------------------------------------------------------------------------------- 424 | 425 | {- 426 | cse :: Eq a => Expr a -> Expr a 427 | cse (Let x0 y0) = let y1 = subst (lift x0) (V Nothing) y0 in Let x0 (cse y1) 428 | where 429 | subst :: Eq b => Expr b -> Expr b -> Expr b -> Expr b 430 | subst x x' y | x == y = x' 431 | 432 | subst x x' (Let y z) 433 | | y == x = instantiate x' z 434 | subst x x' (Let y z) = Let (subst x x' y) (subst (lift x) (lift x') z) 435 | 436 | subst _ _ e@(V _) = e 437 | subst _ _ e@(K _) = e 438 | 439 | subst x x' (ShiftR y n) = ShiftR (subst x x' y) n 440 | subst x x' (Xor y z) = Xor (subst x x' y) (subst x x' z) 441 | subst x x' (Plus y z) = Plus (subst x x' y) (subst x x' z) 442 | subst x x' (ShiftL y n) = ShiftL (subst x x' y) n 443 | subst x x' (Mult y z) = Mult (subst x x' y) (subst x x' z) 444 | subst x x' (Trunc16 y) = Trunc16 (subst x x' y) 445 | subst x x' (Trunc32 y) = Trunc32 (subst x x' y) 446 | 447 | cse e@(V _) = e 448 | cse e@(K _) = e 449 | cse (ShiftR x n) = ShiftR (cse x) n 450 | cse (Xor x y) = Xor (cse x) (cse y) 451 | cse (Mult x y) = Mult (cse x) (cse y) 452 | 453 | cse (ShiftL x n) = ShiftL (cse x) n 454 | cse (Plus x y) = Plus (cse x) (cse y) 455 | 456 | cse (Trunc16 x) = Trunc16 (cse x) 457 | cse (Trunc32 x) = Trunc32 (cse x) 458 | -} 459 | -------------------------------------------------------------------------------- /tools/src/SimulatedAnnealing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} 2 | module SimulatedAnnealing ( 3 | simulatedAnnealing, 4 | Problem (..), 5 | Pretty (..), 6 | ) where 7 | 8 | import System.Random.SplitMix 9 | import Text.Printf 10 | 11 | class Pretty a where 12 | pretty :: a -> String 13 | 14 | data Problem state step = Problem 15 | { pPerturb :: state -> step -> state 16 | , pEnergy :: state -> Double 17 | } 18 | 19 | simulatedAnnealing 20 | :: forall state step. Pretty state 21 | => Problem state step -- ^ problem definition 22 | -> SMGen -- ^ initial generator 23 | -> state -- ^ initial state 24 | -> (SMGen -> step) -- ^ generate step 25 | -> IO (state, Double) 26 | simulatedAnnealing (Problem perturb energy) g0 state0 genStep 27 | = go 0 [] startT g0 state0 (energy state0) 28 | where 29 | -- params 30 | innerSteps :: Int 31 | innerSteps = 128 32 | 33 | startT = 1e-2 34 | 35 | prettySE :: state -> Double -> String 36 | prettySE s e = pretty s ++ printf " E=%.09f" e 37 | 38 | -- loop 39 | go :: Int -> [Double] -> Double -> SMGen -> state -> Double -> IO (state, Double) 40 | go !n !deltaEs !t !g !s !e | n > innerSteps = do 41 | let t' = clamp (0.5 * t) (0.8 * t) (abs $ average deltaEs) 42 | if null deltaEs 43 | then do 44 | putStrLn $ "END: " ++ prettySE s e 45 | return (s, e) 46 | else do 47 | putStrLn $ printf "Temperature drop %5.02e -> %5.02e" t t' 48 | go 0 [] t' g s e 49 | 50 | go n deltaEs t g s e = do 51 | let (g1, g2) = splitSMGen g 52 | let step = genStep g1 53 | let s' = perturb s step 54 | let e' = energy s' 55 | let deltaE = e' - e 56 | let prob | deltaE < 0 = 1 57 | | otherwise = exp (negate deltaE / t) 58 | let (x, g3) = nextDouble g2 59 | 60 | let takeStep = x < prob 61 | 62 | putStrLn $ printf "% 5d | curr: %s | next: %s | ΔE=%+.09f T=%5.02e P=%.09f X=%.09f | %s" 63 | n 64 | (prettySE s e) 65 | (prettySE s' e') 66 | deltaE 67 | t 68 | prob 69 | x 70 | (if takeStep then "take" else "stay") 71 | 72 | let deltaEs' | deltaE < 0 = deltaE : deltaEs 73 | | otherwise = deltaEs 74 | 75 | if takeStep 76 | then go (succ n) deltaEs' t g3 s' e' 77 | else go (succ n) deltaEs' t g3 s e 78 | 79 | average :: [Double] -> Double 80 | average [] = 0 81 | average xs = sum xs / fromIntegral (length xs) 82 | 83 | clamp :: Ord a => a -> a -> a -> a 84 | clamp mi ma x | x < mi = mi 85 | | x > ma = ma 86 | | otherwise = x 87 | --------------------------------------------------------------------------------