packages feed

LogicGrowsOnTrees (empty) → 1.0.0

raw patch · 52 files changed

+13672/−0 lines, 52 filesdep +AbortT-mtldep +AbortT-transformersdep +HUnitsetup-changed

Dependencies added: AbortT-mtl, AbortT-transformers, HUnit, LogicGrowsOnTrees, MonadCatchIO-transformers, PSQueue, QuickCheck, base, bytestring, cereal, cmdtheline, composition, containers, criterion, data-ivar, derive, directory, hslogger, hslogger-template, lens, monoid-statistics, mtl, multiset, operational, prefix-units, pretty, quickcheck-instances, random, sequential-index, smallcheck, stm, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-smallcheck, time, transformers, uuid, void, yjtools

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2012, Gregory Crosswhite+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice,+      this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice,+      this list of conditions and the following disclaimer in the documentation+      and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ LogicGrowsOnTrees.cabal view
@@ -0,0 +1,689 @@+Name:                LogicGrowsOnTrees+Version:             1.0.0+License:             BSD3+License-file:        LICENSE+Author:              Gregory Crosswhite+Maintainer:          Gregory Crosswhite <gcrosswhite@gmail.com>+Bug-reports:         https://github.com/gcross/LogicGrowsOnTrees/issues+Synopsis:            a distributed (parallel) implementation of logic programming via dynamically generated trees+Cabal-version:       >=1.8+Build-type:          Simple+Category:	         Control, Distributed Computing, Logic, Parallelism+Description:+    NOTE:  In addition to the following package description, see+    .+    * <http://github.com/gcross/LogicGrowsOnTrees/blob/master/TUTORIAL.md TUTORIAL.md>+     for a tutorial,+    .+    * <http://github.com/gcross/LogicGrowsOnTrees/blob/master/USERS_GUIDE.md USERS_GUIDE.md>+     for a user's guide that provides more information about+     how to use this package, and+    .+    * <http://github.com/gcross/LogicGrowsOnTrees/blob/master/README.md README.md>+     for an FAQ.+    .+    You can think of this package in two equivalent ways. First, you can think+    of it as an implementation of logic programming that is designed to be+    parellelized using workers that have no memory shared between them (hence,+    \"distributed\"). Second, you can think of this package as providing+    infrastructure for exploring a tree in parallel. The connection between+    these two perspectives is that logic programming involves making+    nondeterministic choices, and each such choice is equivalent to a branch+    point in a tree representing the search space of the logic program. In the+    rest of the reference documentation we will focus on the tree perspective+    simply because a lot of the functionality makes the most sense from the+    perspective of working with trees, but one is always free to ignore this and+    simply write a logic program using the standard approach of using+    'MonadPlus' to indicate choice and failure, and the 'Tree' implementation of+    this typeclass will take care of the details of turning your logic program+    into tree. (If you are not familiar with this approach, then see+    <http://github.com/gcross/LogicGrowsOnTrees/blob/master/TUTORIAL.md+    TUTORIAL.md>.)+    .+    To use this package, you first write a function that builds a tree (say, by+    using logic programming); the "LogicGrowsOnTrees" module provides+    functionality to assist in this. You may have your function either return a+    generic 'MonadPlus' or 'MonadExplorable' (where the latter lets you cache+    expensive intermediate calculations so that they do not have to be performed+    again if this path is re-explored later), or you may have it return a 'Tree'+    (or one of its impure friends) directly. You can then test your tree using+    the visting functions in the "LogicGrowsOnTrees" module.+    .+    WARNING: If you need something like state in your tree, then you should+    stack the state monad (or whatever else you want) /on top/ of 'Tree' rather+    than below it. The reason for this is that if you stack the monad below+    'TreeT', then your monad will be affected by the order in which the tree is+    explored, which is almost never what you want, in part because if you are+    not careful then you will break the assumption made by the checkpointing and+    parallelization infrastructure that it does not matter in what order the+    tree is explored or even whether some parts are explored twice or not at all+    in a given run. If side-effects that are not undone by backtracking is+    indeed what you want, then you need to make sure that your side-effects do+    not break this assumption; for example, a monad which memoizes a pure+    function is perfectly fine. By contrast if you are working within the `IO`+    monad and writing results to a database rather than returning them (and+    assuming that duplicate results would cause problems) then you need to check+    to make sure you aren't writing the same result twice, such as by using the+    "LogicGrowsOnTrees.Location" functionality to identify where you are in the+    tree so you can query to see if your current location is already listed in+    the database.+    .+    If you want to see examples of generating a tree to solve a problem, then+    see "LogicGrowsOnTrees.Examples.MapColoring" or+    "LogicGrowsOnTrees.Examples.Queens" modules, which have some basic examples+    of using logic programming to find and/or count the number of solutions to a+    given map coloring problem and a given n-queens problem. The+    "LogicGrowsOnTrees.Examples.Queens.Advanced" module has my own solution to+    the n-queens problem where I use symmetry breaking to prune the search tree,+    cutting the runtime by about a factor of three.+    .+    Once your tree has been debugged, you can start taking advantage of the+    major features of this package. If you are interested in checkpointing, but+    not parallelization, then you can use the step functions in the+    "LogicGrowsOnTrees.Checkpoint" module to sequentially explore a tree one+    node at a time, saving the current checkpoint as often as you desire; at any+    time the exploration can be aborted and resumed later. Most likely, though,+    you will be interested in using the parallelization infrastructure rather+    than just the checkpointing infrastructure. The parallelization+    infrastructure uses a supervisor/worker model, and is designed such that the+    logic used to keep track of the workers and the current progress is+    abstracted away into the "LogicGrowsOnTrees.Parallel.Common.Supervisor"+    module; one then uses one of the provided adapters (or possibly your own) to+    connect the abstract model to a particular means of running multiple+    computations in parallel, such as multiple threads, multiple processes on+    the same machine, multiple processes on a network, and MPI; the first option+    is included in this package and the others are provided in separate+    packages. Parallelization is obtained by stealing workloads from workers;+    specifically, a selected worker will look back at the (non-frozen) choices+    it has made so far, pick the first one, freeze it (so that it won't+    backtrack and try the other branch), and then hand the other branch to the+    supervisor which will then give it to a waiting worker.+    .+    To use the parallelization infrastructure, you have two choices. First, you+    can opt to use the adapter directly; the exploration functions provided by+    the adapter are relatively simple (compared to the alternative to be+    discussed in a moment) and furthermore, they give you maximum control over+    the adapter, but the downside is that you will have to re-implement features+    such as regular checkpointing and forwarding information from the command+    line to the workers yourself. Second, you can use the infrastructure in+    "LogicGrowsOnTrees.Parallel.Main", which automates most of the process for+    you, including parsing the command lines, sending information to the+    workers, determining how many workers (if applicable) to start up, offering+    the user a command line option to specify whether, where, and how often to+    checkpoint, etc.; this infrastructure is also completely adapter+    independent, which means that when switching from one adapter to another all+    you have to do is change one of the arguments in your call to the main+    function you are using in "LogicGrowsOnTrees.Parallel.Main". The downside is+    that the call to use this functionality is a bit more complex than the call+    to use a particular adapter precisely because of its generality.+    .+    If you want to see examples of using the "LogicGrowsOnTrees.Parallel.Main"+    module, check out the example executables in the @examples/@ subdirectory of+    the source distribution.+    .+    If you are interested in writing a new adapter, then you have couple of+    options. First, if your adapter can spawn and destroy workers on demand,+    then you should look at the "LogicGrowsOnTrees.Parallel.Common.Workgroup"+    module, as it has infrastructure designed for this case; look at+    "LogicGrowsOnTrees.Parallel.Adapter.Threads" for an example of using it.+    Second, if your adapter does not meet this criterion, then you should look+    at the "LogicGrowsOnTrees.Parallel.Common.Supervisor" module; your adapter+    will need to run within the 'SupervisorMonad', with its own state contained+    in its own monad below the 'SupervisorMonad' monad in the stack; for an+    example, look at the @LogicGrowsOnTrees-network@ module.+    .+    NOTE: This package uses the @hslogger@ package for logging; if you set the+    log level to INFO or DEBUG (either by calling the functions in @hslogger@+    yourself or by using the @-l@ command line option if you are using `Main`)+    then many status messages will be printed to the screen (or wherever else+    the log has been configured to be written).+    .+    The modules are organized as follows:+    .+        ["LogicGrowsOnTrees"] basic infrastructure for building and exploring trees+    .+        ["LogicGrowsOnTrees.Checkpoint"] infrastructure for creating and stepping through checkpoints+    .+        ["LogicGrowsOnTrees.Examples.MapColoring"] simple examples of computing all possible colorings of a map+    .+        ["LogicGrowsOnTrees.Examples.Queens"] simple examples of solving the n-quees problem+    .+        ["LogicGrowsOnTrees.Examples.Queens.Advanced"] a very complicated example of solving the n-queens problem using symmetry breaking+    .+        ["LogicGrowsOnTrees.Location"] infrastructure for when you want to have knowledge of your current location within a tree+    .+        ["LogicGrowsOnTrees.Parallel.Adapter.Threads"] the threads adapter+    .+        ["LogicGrowsOnTrees.Parallel.Common.Message"] common infrastructure for exchanging messages between worker and supervisor+    .+        ["LogicGrowsOnTrees.Parallel.Common.Process"] common infrastricture for the case where a worker has specific communications channels for sending and recieving messages; it might seem like this should always be the case, but it is not true for threads, as the supervisor has direct access to the worker thread, nor for MPI which has its own idiosyncratic communication model+    .+        ["LogicGrowsOnTrees.Parallel.Common.RequestQueue"] infrastructure for sending requests to the 'SupervisorMonad' from another thread+    .+        ["LogicGrowsOnTrees.Parallel.Common.Supervisor"] common infrastructure for keeping track of the state of workers and of the system as a whole, including determining when the run is over+    .+        ["LogicGrowsOnTrees.Parallel.Common.Worker"] contains the workhorse of the parallel infrastructure:  a thread that steps through a given workload while continuously polling for requests+    .+        ["LogicGrowsOnTrees.Parallel.Common.Workgroup"] common infrastructure for the case where workers can be added and removed from the system on demand+    .+        ["LogicGrowsOnTrees.Parallel.ExplorationMode"] specifies the various modes in which the exploration can be done+    .+        ["LogicGrowsOnTrees.Parallel.Main"] a unified interface to the various adapters that automates much of the process such as processing the command, forwarding the needed information to the workers, and performing regular checkpointing if requested via a command line argument+    .+        ["LogicGrowsOnTrees.Parallel.Purity"] specifies the purity of the tree being explored+    .+        ["LogicGrowsOnTrees.Path"] infrastructure for working with paths trough the search tree+    .+        ["LogicGrowsOnTrees.Utils.Handle"] a couple of utility functions for exchanging serializable data over handles+    .+        ["LogicGrowsOnTrees.Utils.IntSum"] a monoid that contains an 'Int' to be summed over+    .+        ["LogicGrowsOnTrees.Utils.PerfectTree"] provides algorithms for generating various simple trees+    .+        ["LogicGrowsOnTrees.Utils.WordSum"] a monoid that contains a 'Word' to be summed over+    .+        ["LogicGrowsOnTrees.Utils.Word_"] a newtype wrapper that provides an `ArgVal` instance for `Word`+    .+        ["LogicGrowsOnTrees.Workload"] infrastructure for working with 'Workload's+    .+    Of the above modules, the ones you will be using most often+    are "LogicGrowsOnTrees" (for building trees), one of the+    adapter modules (such as+    "LogicGrowsOnTrees.Parallel.Adapter.Threads"), and possibly+    "LogicGrowsOnTrees.Parallel.Main". If you are counting the+    number of solutions, then you will also want to look at+    "LogicGrowsOnTrees.Utils.WordSum". Finally, if your program+    takes a 'Word' as a command line argument or option then+    you might find the "LogicGrowsOnTrees.Utils.Word_" module+    to be useful. The other modules provide lower-level+    functionality; in particular the+    @LogicGrowsOnTrees.Parallel.Common.*@ modules are primarily+    geared towards people writing their own adapter.++Extra-source-files: c-sources/queens.c++Source-Repository head+    Type:     git+    Location: git://github.com/gcross/LogicGrowsOnTrees.git++Source-Repository this+    Type:     git+    Location: git://github.com/gcross/LogicGrowsOnTrees.git+    Tag:      1.0.0++Library+    Build-depends:+        AbortT-transformers == 1.0.*,+        AbortT-mtl == 1.0.*,+        base > 4 && < 5,+        bytestring >= 0.9 && < 0.11,+        cereal == 0.3.*,+        cmdtheline == 0.2.*,+        composition >= 0.2 && < 1.1,+        containers >= 0.4 && < 0.6,+        data-ivar == 0.30.*,+        derive >= 2.5.11 && < 2.6,+        directory >= 1.1 && < 1.3,+        hslogger == 1.2.*,+        hslogger-template == 2.0.*,+        lens >= 3.8 && < 3.10,+        MonadCatchIO-transformers == 0.3.*,+        monoid-statistics == 0.3.*,+        mtl == 2.1.*,+        multiset == 0.2.*,+        operational == 0.2.*,+        prefix-units == 0.1.*,+        pretty == 1.1.*,+        PSQueue == 1.1.*,+        sequential-index == 0.2.*,+        stm >= 2.3 && < 2.5,+        time == 1.4.*,+        transformers >= 0.2 && < 0.4,+        void == 0.6.*,+        yjtools >= 0.9.7 && < 0.10+    Exposed-modules:+        LogicGrowsOnTrees+        LogicGrowsOnTrees.Checkpoint+        LogicGrowsOnTrees.Examples.MapColoring+        LogicGrowsOnTrees.Examples.Queens+        LogicGrowsOnTrees.Examples.Queens.Advanced+        LogicGrowsOnTrees.Location+        LogicGrowsOnTrees.Parallel.Adapter.Threads+        LogicGrowsOnTrees.Parallel.Common.Message+        LogicGrowsOnTrees.Parallel.Common.Process+        LogicGrowsOnTrees.Parallel.Common.RequestQueue+        LogicGrowsOnTrees.Parallel.Common.Supervisor+        LogicGrowsOnTrees.Parallel.Common.Workgroup+        LogicGrowsOnTrees.Parallel.Common.Worker+        LogicGrowsOnTrees.Parallel.ExplorationMode+        LogicGrowsOnTrees.Parallel.Main+        LogicGrowsOnTrees.Parallel.Purity+        LogicGrowsOnTrees.Path+        LogicGrowsOnTrees.Utils.Handle+        LogicGrowsOnTrees.Utils.IntSum+        LogicGrowsOnTrees.Utils.PerfectTree+        LogicGrowsOnTrees.Utils.Word_+        LogicGrowsOnTrees.Utils.WordSum+        LogicGrowsOnTrees.Workload+    Other-modules:+        LogicGrowsOnTrees.Parallel.Common.Supervisor.Implementation+    HS-source-dirs: sources+    C-sources: c-sources/queens.c+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing+    if flag(pattern-warnings)+        GHC-Options: -fwarn-incomplete-patterns++Flag warnings+    Description: Enables most warnings.+    Default:     False++Flag pattern-warnings+    Description: Enables only pattern match warnings.+    Default:     False++Flag examples+    Description: Enable building the examples.+    Default:     False++Flag tutorial+    Description: Enable building the tutorial examples.+    Default:     False++Executable readme-simple+    Main-is: readme-simple.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable readme-full+    Main-is: readme-full.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable count-all-nqueens-solutions+    Main-is: count-all-nqueens-solutions.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable print-all-nqueens-solutions+    Main-is: print-all-nqueens-solutions.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable print-an-nqueens-solution+    Main-is: print-an-nqueens-solution.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable print-some-nqueens-solutions-using-pull+    Main-is: print-some-nqueens-solutions-using-pull.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable print-some-nqueens-solutions-using-push+    Main-is: print-some-nqueens-solutions-using-push.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*,+        containers >= 0.4 && < 0.6+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable count-all-trivial-tree-leaves+    Main-is: count-all-trivial-tree-leaves.hs+    Hs-source-dirs: examples+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cereal == 0.3.*,+        cmdtheline == 0.2.*+    if flag(examples)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-1+    Main-is: tutorial-1.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Executable tutorial-2+    Main-is: tutorial-2.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        containers >= 0.4 && < 0.6+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Executable tutorial-3+    Main-is: tutorial-3.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Executable tutorial-4+    Main-is: tutorial-4.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Executable tutorial-5+    Main-is: tutorial-5.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Executable tutorial-6+    Main-is: tutorial-6.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-7+    Main-is: tutorial-7.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        transformers >= 0.2 && < 0.4+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-8+    Main-is: tutorial-8.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        transformers >= 0.2 && < 0.4+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-9+    Main-is: tutorial-9.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-10+    Main-is: tutorial-10.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-11+    Main-is: tutorial-11.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-12+    Main-is: tutorial-12.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Executable tutorial-13+    Main-is: tutorial-12.hs+    Hs-source-dirs: tutorial+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        cmdtheline == 0.2.*+    if flag(tutorial)+        Buildable: True+    else+        Buildable: False+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -threaded+    else+        GHC-Options: -threaded++Benchmark tree-versus-list-trivial-tree+    Type: exitcode-stdio-1.0+    Main-is: tree-versus-list-trivial-tree.hs+    Hs-source-dirs: benchmarks+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        criterion >= 0.6 && < 0.9+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Benchmark tree-versus-list-nqueens+    Type: exitcode-stdio-1.0+    Main-is: tree-versus-list-nqueens.hs+    Hs-source-dirs: benchmarks+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        criterion >= 0.6 && < 0.9+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing++Test-Suite tests+    Type: exitcode-stdio-1.0+    Main-is: tests.hs+    Hs-source-dirs: tests+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        bytestring >= 0.9 && < 0.11,+        cereal == 0.3.*,+        composition >= 0.2 && < 1.1,+        containers >= 0.4 && < 0.6,+        data-ivar == 0.30.*,+        directory >= 1.1 && < 1.3,+        hslogger == 1.2.*,+        hslogger-template == 2.0.*,+        HUnit == 1.2.*,+        lens >= 3.8 && < 3.10,+        operational == 0.2.*,+        random == 1.0.*,+        QuickCheck >= 2.4 && < 2.7,+        quickcheck-instances >= 0.3.1 && < 0.4,+        smallcheck == 1.0.*,+        stm >= 2.3 && < 2.5,+        test-framework >= 0.6 && < 0.9,+        test-framework-hunit >= 0.2 && < 0.4,+        test-framework-quickcheck2 >= 0.2 && < 0.4,+        test-framework-smallcheck == 0.2.*,+        transformers >= 0.2 && < 0.4,+        uuid == 1.2.*,+        void == 0.6.*+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing -with-rtsopts=-M256M+    else+        GHC-Options: -with-rtsopts=-M256M++Test-Suite test-nqueens+    Type: exitcode-stdio-1.0+    Main-is: test-nqueens.hs+    Hs-source-dirs: tests+    Build-depends:+        LogicGrowsOnTrees,+        base > 4 && < 5,+        containers >= 0.4 && < 0.6,+        HUnit == 1.2.*,+        QuickCheck >= 2.4 && < 2.7,+        test-framework >= 0.6 && < 0.9,+        test-framework-hunit >= 0.2 && < 0.4,+        test-framework-quickcheck2 >= 0.2 && < 0.4,+        transformers >= 0.2 && < 0.4+    if flag(warnings)+        GHC-Options: -Wall -fno-warn-name-shadowing
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/tree-versus-list-nqueens.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE UnicodeSyntax #-}++import Criterion.Main+import Data.Monoid++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Examples.Queens+import LogicGrowsOnTrees.Utils.WordSum+import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric)+import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode))+import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure))++main = defaultMain+    [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensCount) n+    ,bench "tree" $ nf (getWordSum . exploreTree . nqueensCount) n+    ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensCount) n+    ,bench "tree using worker" $ exploreTreeGeneric AllMode Pure (nqueensCount n)+    ]+  where n = 13
+ benchmarks/tree-versus-list-trivial-tree.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE UnicodeSyntax #-}++import Criterion.Main+import Data.Monoid++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Utils.PerfectTree+import LogicGrowsOnTrees.Utils.WordSum+import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric)+import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode))+import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure))++main = defaultMain+    [bench "list" $ nf (getWordSum . mconcat . trivialPerfectTree 2) depth+    ,bench "tree" $ nf (getWordSum . exploreTree . trivialPerfectTree 2) depth+    ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . trivialPerfectTree 2) depth+    ,bench "tree using worker" $ exploreTreeGeneric AllMode Pure (trivialPerfectTree 2 depth)+    ]+  where depth = 15
+ c-sources/queens.c view
@@ -0,0 +1,79 @@+#include <stddef.h>+#include <stdint.h>++unsigned int LogicGrowsOnTrees_Queens_count_solutions(+    unsigned int size,+    unsigned int number_of_queens_remaining,+    unsigned int row,+    uint64_t occupied_rows,+    uint64_t occupied_columns,+    uint64_t occupied_negative_diagonals,+    uint64_t occupied_positive_diagonals,+    void (*pushValue)(unsigned int,unsigned int),+    void (*popValue)(),+    void (*finalizeValue)()+) {+    if(occupied_rows & 1 != 0) {+        return+            LogicGrowsOnTrees_Queens_count_solutions(+                size,+                number_of_queens_remaining,+                row+1,+                occupied_rows >> 1,+                occupied_columns,+                occupied_negative_diagonals >> 1,+                (occupied_positive_diagonals << 1) + ((occupied_positive_diagonals >> 63) & 1),+                pushValue,+                popValue,+                finalizeValue+            );+    }+    unsigned int+        number_of_solutions = 0,+        column_bit = 1,+        column = 0;+    uint64_t blocked = occupied_columns | occupied_negative_diagonals | occupied_positive_diagonals;+    for(column = 0; column < size; ++column, column_bit <<= 1) {+        if((column_bit & blocked) == 0) {+            #ifdef __GNUC__+            if(__builtin_expect(pushValue != NULL,0)) {+            #else+            if(pushValue != NULL) {+            #endif+                (*pushValue)(row,column);+            }+            if(number_of_queens_remaining == 1) {+                #ifdef __GNUC__+                if(__builtin_expect(finalizeValue != NULL,0)) {+                #else+                if(finalizeValue != NULL) {+                #endif+                    (*finalizeValue)();+                }+                number_of_solutions += 1;+            } else {+                number_of_solutions +=+                    LogicGrowsOnTrees_Queens_count_solutions(+                        size,+                        number_of_queens_remaining-1,+                        row+1,+                        occupied_rows >> 1,+                        occupied_columns | column_bit,+                        (occupied_negative_diagonals | column_bit) >> 1,+                        ((occupied_positive_diagonals | column_bit) << 1) + ((occupied_positive_diagonals >> 63) & 1),+                        pushValue,+                        popValue,+                        finalizeValue+                    );+            }+            #ifdef __GNUC__+            if(__builtin_expect(popValue != NULL,0)) {+            #else+            if(popValue != NULL) {+            #endif+                (*popValue)(row,column);+            }+        }+    }+    return number_of_solutions;+}
+ examples/count-all-nqueens-solutions.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE UnicodeSyntax #-}++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads+import LogicGrowsOnTrees.Utils.WordSum++import LogicGrowsOnTrees.Examples.Queens++main =+    mainForExploreTree+        driver+        (makeBoardSizeTermAtPosition 0)+        (defTI { termDoc = "count the number of n-queens solutions for a given board size" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed (WordSum count) → print count+                Failure _ message → error $ "error: " ++ message+        )+        nqueensCount
+ examples/count-all-trivial-tree-leaves.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads+import LogicGrowsOnTrees.Utils.PerfectTree+import LogicGrowsOnTrees.Utils.WordSum++main =+    mainForExploreTree+        driver+        (makeArityAndDepthTermAtPositions 0 1)+        (defTI { termDoc = "count the leaves of a tree" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed (WordSum count) → print count+                Failure _ message → error $ "error: " ++ message+        )+        (trivialPerfectTree <$> arity <*> depth)
+ examples/print-all-nqueens-solutions.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UnicodeSyntax #-}++import System.Console.CmdTheLine++import qualified Data.Foldable as Fold+import Data.List (sort)+import qualified Data.Sequence as Seq++import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads++import LogicGrowsOnTrees.Examples.Queens++main =+    mainForExploreTree+        driver+        (makeBoardSizeTermAtPosition 0)+        (defTI { termDoc = "print all the n-queens solutions for a given board size" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed solutions → Fold.mapM_ print . Seq.unstableSort $ solutions+                Failure _ message → error $ "error: " ++ message+        )+        (fmap (Seq.singleton . sort) . nqueensSolutions)+
+ examples/print-an-nqueens-solution.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UnicodeSyntax #-}++import Data.List (sort)++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads++import LogicGrowsOnTrees.Examples.Queens++main =+    mainForExploreTreeUntilFirst+        driver+        (makeBoardSizeTermAtPosition 0)+        (defTI { termDoc = "print an n-queens solutions for a given board size" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed Nothing → putStrLn "No solution found."+                Completed (Just (Progress _ result)) → print (sort result)+                Failure _ message → error $ "error: " ++ message+        )+        nqueensSolutions+
+ examples/print-some-nqueens-solutions-using-pull.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative ((<$>),(<*>))++import qualified Data.Foldable as Fold+import Data.List (sort)+import qualified Data.Sequence as Seq++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads++import LogicGrowsOnTrees.Examples.Queens++main =+    mainForExploreTreeUntilFoundUsingPull+        (\(_,number_of_solutions) → (>= number_of_solutions) . Seq.length)+        driver+        ((,) <$> makeBoardSizeTermAtPosition 0+             <*> required (pos 1 Nothing (posInfo { posName = "SOLUTIONS", posDoc = "number of solutions" }))+        )+        (defTI { termDoc = "print the requested number of n-queens solutions (or at least as many as found) for a given board size" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed (Left solutions) → do+                    case Seq.length solutions of+                        0 → putStrLn "No solutions were found."+                        1 → do putStrLn $ "Only one solution was found:"+                               Fold.mapM_ print $ solutions+                        n → do putStrLn $ "Only " ++ show n ++ " solutions were found:"+                               Fold.mapM_ print $ solutions+                Completed (Right (Progress _ solutions)) → do+                    Fold.mapM_ print . Seq.unstableSort $ solutions+                Failure _ message → error $ "error: " ++ message+        )+        (fmap (Seq.singleton . sort) . nqueensSolutions . fst)+
+ examples/print-some-nqueens-solutions-using-push.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative ((<$>),(<*>))++import qualified Data.Foldable as Fold+import Data.List (sort)+import qualified Data.Sequence as Seq++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads++import LogicGrowsOnTrees.Examples.Queens++main =+    mainForExploreTreeUntilFoundUsingPush+        (\(_,number_of_solutions) → (>= number_of_solutions) . Seq.length)+        driver+        ((,) <$> makeBoardSizeTermAtPosition 0+             <*> required (pos 1 Nothing (posInfo { posName = "SOLUTIONS", posDoc = "number of solutions" }))+        )+        (defTI { termDoc = "print the requested number of n-queens solutions (or at least as many as found) for a given board size" })+        (\_ (RunOutcome _ termination_reason) → do+            case termination_reason of+                Aborted _ → error "search aborted"+                Completed (Left solutions) → do+                    case Seq.length solutions of+                        0 → putStrLn "No solutions were found."+                        1 → do putStrLn $ "Only one solution was found:"+                               Fold.mapM_ print $ solutions+                        n → do putStrLn $ "Only " ++ show n ++ " solutions were found:"+                               Fold.mapM_ print $ solutions+                Completed (Right (Progress _ solutions)) →+                    Fold.mapM_ print . Seq.unstableSort $ solutions+                Failure _ message → error $ "error: " ++ message+        )+        (fmap (Seq.singleton . sort) . nqueensSolutions . fst)+
+ examples/readme-full.hs view
@@ -0,0 +1,84 @@+import Control.Applicative+import Control.Monad+import qualified Data.IntSet as IntSet+import System.Console.CmdTheLine++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads+import LogicGrowsOnTrees.Utils.Word_+import LogicGrowsOnTrees.Utils.WordSum++-- Code that counts all the solutions for a given input board size.+nqueensCount 0 = error "board size must be positive"+nqueensCount n =+    -- Start with...+    go n -- ...n queens left...+       0 -- ... at row zero...+       -- ... with all columns available ...+       (IntSet.fromDistinctAscList [0..fromIntegral n-1])+       IntSet.empty -- ... with no occupied negative diagonals...+       IntSet.empty -- ... with no occupied positive diagonals.+  where+    -- We have placed the last queen, so this is a solution!+    go 0 _ _ _ _ = return (WordSum 1)++    -- We are still placing queens.+    go n+       row+       available_columns+       occupied_negative_diagonals+       occupied_positive_diagonals+     = do+        -- Pick one of the available columns.+        column <- allFrom $ IntSet.toList available_columns++        -- See if this spot conflicts with another queen on the negative diagonal.+        let negative_diagonal = row + column+        guard $ IntSet.notMember negative_diagonal occupied_negative_diagonals++        -- See if this spot conflicts with another queen on the positive diagonal.+        let positive_diagonal = row - column+        guard $ IntSet.notMember positive_diagonal occupied_positive_diagonals++        -- This spot is good!  Place a queen here and move on to the next row.+        go (n-1)+           (row+1)+           (IntSet.delete column available_columns)+           (IntSet.insert negative_diagonal occupied_negative_diagonals)+           (IntSet.insert positive_diagonal occupied_positive_diagonals)++main =+    -- Explore the tree generated (implicitly) by nqueensCount in parallel.+    mainForExploreTree+        -- Use threads for parallelism.+        driver++        -- Use a single positional required command-line argument to get the board size.+        (getWord+         <$>+         (required+          $+          pos 0+            Nothing+            posInfo+              { posName = "BOARD_SIZE"+              , posDoc = "board size"+              }+         )+        )++        -- Information about the program (for the help screen).+        (defTI { termDoc = "count the number of n-queens solutions for a given board size" })++        -- Function that processes the result of the run.+        (\n (RunOutcome _ termination_reason) -> do+            case termination_reason of+                Aborted _ -> error "search aborted"+                Completed (WordSum count) -> putStrLn $+                    "for a size " ++ show n ++ " board, found " ++ show count ++ " solutions"+                Failure _ message -> error $ "error: " ++ message+        )++        -- The logic program that generates the tree to explore.+        nqueensCount
+ examples/readme-simple.hs view
@@ -0,0 +1,63 @@+import Control.Monad+import qualified Data.IntSet as IntSet++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.Threads+import LogicGrowsOnTrees.Utils.WordSum++-- Code that counts all the solutions for a given input board size.+nqueensCount 0 = error "board size must be positive"+nqueensCount n =+    -- Start with...+    go n -- ...n queens left...+       0 -- ... at row zero...+       -- ... with all columns available ...+       (IntSet.fromDistinctAscList [0..fromIntegral n-1])+       IntSet.empty -- ... with no occupied negative diagonals...+       IntSet.empty -- ... with no occupied positive diagonals.+  where+    -- We have placed the last queen, so this is a solution!+    go 0 _ _ _ _ = return (WordSum 1)++    -- We are still placing queens.+    go n+       row+       available_columns+       occupied_negative_diagonals+       occupied_positive_diagonals+     = do+        -- Pick one of the available columns.+        column <- allFrom $ IntSet.toList available_columns++        -- See if this spot conflicts with another queen on the negative diagonal.+        let negative_diagonal = row + column+        guard $ IntSet.notMember negative_diagonal occupied_negative_diagonals++        -- See if this spot conflicts with another queen on the positive diagonal.+        let positive_diagonal = row - column+        guard $ IntSet.notMember positive_diagonal occupied_positive_diagonals++        -- This spot is good!  Place a queen here and move on to the next row.+        go (n-1)+           (row+1)+           (IntSet.delete column available_columns)+           (IntSet.insert negative_diagonal occupied_negative_diagonals)+           (IntSet.insert positive_diagonal occupied_positive_diagonals)++main =+    -- Explore the tree generated (implicitly) by nqueensCount in parallel.+    simpleMainForExploreTree+        -- Use threads for parallelism.+        driver++        -- Function that processes the result of the run.+        (\(RunOutcome _ termination_reason) -> do+            case termination_reason of+                Aborted _ -> error "search aborted"+                Completed (WordSum count) -> putStrLn $ "found " ++ show count ++ " solutions"+                Failure _ message -> error $ "error: " ++ message+        )++        -- The logic program that generates the tree to explore.+        (nqueensCount 10)
+ sources/LogicGrowsOnTrees.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| Basic functionality for building and exploring trees. -}+module LogicGrowsOnTrees+    (+    -- * Tree types+    -- $types+      Tree+    , TreeIO+    , TreeT(..)+    -- * Explorable class features+    -- $type-classes+    , MonadExplorable(..)+    , MonadExplorableTrans(..)+    -- * Functions+    -- $functions++    -- ** ...that explore trees+    -- $runners+    , exploreTree+    , exploreTreeT+    , exploreTreeTAndIgnoreResults+    , exploreTreeUntilFirst+    , exploreTreeTUntilFirst+    , exploreTreeUntilFound+    , exploreTreeTUntilFound+    -- ** ...that help building trees+    -- $builders+    , allFrom+    , between+    -- ** ...that transform trees+    , endowTree+    -- * Implementation+    -- $implementation+    , TreeTInstruction(..)+    , TreeInstruction+    ) where++import Control.Applicative (Alternative(..),Applicative(..))+import Control.Monad (MonadPlus(..),(>=>),liftM,liftM2,msum)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Operational (ProgramT,ProgramViewT(..),singleton,view,viewT)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.List (ListT)+import Control.Monad.Trans.Maybe (MaybeT)++import Data.Foldable (Foldable)+import qualified Data.Foldable as Fold++import Data.Functor.Identity (Identity(..),runIdentity)+import Data.Maybe (isJust)+import Data.Monoid ((<>),Monoid(..))+import Data.Serialize (Serialize(),encode)++--------------------------------------------------------------------------------+------------------------------------- Types ------------------------------------+--------------------------------------------------------------------------------++{- $types+The following are the tree types that are accepted by most of the functions in+this package. You do not need to know the details of their definitions unless+you intend to write your own custom routines for running and transforming trees,+in which case the relevant information is at the bottom of this page in the+Implementation section.++There is one type of pure tree and two types of impure trees. In general, your+tree should nearly always be pure if you are planning to make use of+checkpointing or parallel exploring, as parts of the tree may be explored+multiple times, some parts may not be run at all on a given processor, and+whenever a leaf is hit there will be a jump to a higher node, so if your tree is+impure then the result needs to not depend on how the tree is explored; an+example of an acceptable use of an inner monad is when you want to memoize a+pure function using a stateful monad.++If you need something like state in your tree, then you should consider+nesting the tree monad in the state monad rather than vice-versa,+because this will do things like automatically erasing the change in state that+happened between an inner node and a leaf when the tree jumps back up+from the leaf to an inner node, which will usually be what you want.+-}++{-| A pure tree, which is what you should normally be using. -}+type Tree = TreeT Identity++{-| A tree running in the I/O monad, which you should only be using for doing+    things like reading data from an external file or database that will be+    constant for the entire run.+-}+type TreeIO = TreeT IO++{-| A tree run in an arbitrary monad. -}+newtype TreeT m α = TreeT { unwrapTreeT :: ProgramT (TreeTInstruction m) m α }+    deriving (Applicative,Functor,Monad,MonadIO)++--------------------------------------------------------------------------------+--------------------------------- Type-classes ---------------------------------+--------------------------------------------------------------------------------++{- $type-classes++'Tree's are instances of 'MonadExplorable' and 'MonadExplorableTrans',+which are both subclasses of 'MonadPlus'. The additional functionality offered+by these type-classes is the ability to cache results so that a computation does+not need to be repeated when a node is explored a second time, which can happen+either when resuming from a checkpoint or when a workload has been stolen by+another processor, as the first step is to retrace the path through the tree+that leads to the stolen workload.++These features could have been provided as functions, but there are two reasons+why they were subsumed into type-classes: first, because one might want to+add another layer above the 'Tree' monad transformers in the monad stack+(as is the case in "LogicGrowsOnTrees.Location"), and second, because one might want+to run a tree using a simpler monad such as List for testing purposes.++NOTE:  Caching a computation takes space in the 'Checkpoint', so it is something+       you should only do when the result is relatively small and the+       computation is very expensive and is high enough in the search tree that+       it is likely to be repeated often.  If the calculation is low enough in+       the search tree that it is unlikely to be repeated, is cheap enough so+       that repeating it is not a big deal, or produces a result with an+       incredibly large memory footprint, then you are probably better off not+       caching the result.+ -}++{-| The 'MonadExplorable' class provides caching functionality when exploring a+    tree, as well as a way to give a worker a chance to process any pending+    requests; at minimum 'cacheMaybe' needs to be defined.+ -}+class MonadPlus m ⇒ MonadExplorable m where+    {-| Cache a value in case we explore this node again. -}+    cache :: Serialize x ⇒ x → m x+    cache = cacheMaybe . Just++    {-| This does the same thing as 'guard' but it caches the result. -}+    cacheGuard :: Bool → m ()+    cacheGuard = cacheMaybe . (\x → if x then Just () else Nothing)++    {-| This function is a combination of the previous two;  it performs a+        computation which might fail by returning 'Nothing', and if that happens+        it then backtracks; if it passes then the result is cached and returned.++        Note that the previous two methods are essentially specializations of+        this method.+     -}+    cacheMaybe :: Serialize x ⇒ Maybe x → m x++    {-| This function tells the worker to take a break to process any pending+        requests; it does nothing if we are not in a parallel setting.++        NOTE: You should normally never need to use this function, as requests+        are processed whenever a choice point, a cache point, mzero, or a leaf+        in the decision tree has been encountered. However, if you have noticed+        that workload steals are taking such a large amount of time that workers+        are spending too much time sitting idle while they wait for a workload,+        and you can trace this as being due to a computation that takes so much+        time that it almost never gives the worker a chance to process requests,+        then you can use this method to ensure that requests are given a chance+        to be processed.+     -}+    processPendingRequests :: m ()+    processPendingRequests = return ()++{-| This class is like 'MonadExplorable', but it is designed to work with monad+    stacks;  at minimum 'runAndCacheMaybe' needs to be defined.+ -}+class (MonadPlus m, Monad (NestedMonad m)) ⇒ MonadExplorableTrans m where+    {-| The next layer down in the monad transformer stack. -}+    type NestedMonad m :: * → *++    {-| Runs the given action in the nested monad and caches the result. -}+    runAndCache :: Serialize x ⇒ (NestedMonad m) x → m x+    runAndCache = runAndCacheMaybe . liftM Just++    {-| Runs the given action in the nested monad and then does the equivalent+        of feeding it into 'guard', caching the result.+     -}+    runAndCacheGuard :: (NestedMonad m) Bool → m ()+    runAndCacheGuard = runAndCacheMaybe . liftM (\x → if x then Just () else Nothing)++    {-| Runs the given action in the nested monad;  if it returns 'Nothing',+        then it acts like 'mzero',  if it returns 'Just x', then it caches the+        result.+     -}+    runAndCacheMaybe :: Serialize x ⇒ (NestedMonad m) (Maybe x) → m x++--------------------------------------------------------------------------------+---------------------------------- Instances -----------------------------------+--------------------------------------------------------------------------------++{-| The 'Alternative' instance functions just like the 'MonadPlus' instance. -}+instance Monad m ⇒ Alternative (TreeT m) where+    empty = mzero+    (<|>) = mplus++{-| Two 'Tree's are equal if they have the same structure. -}+instance Eq α ⇒ Eq (Tree α) where+    (TreeT x) == (TreeT y) = e x y+      where+        e x y = case (view x, view y) of+            (Return x, Return y) → x == y+            (Null :>>= _, Null :>>= _) → True+            (Cache cx :>>= kx, Cache cy :>>= ky) →+                case (runIdentity cx, runIdentity cy) of+                    (Nothing, Nothing) → True+                    (Just x, Just y) → e (kx x) (ky y)+                    _ → False+            (Choice (TreeT ax) (TreeT bx) :>>= kx, Choice (TreeT ay) (TreeT by) :>>= ky) →+                e (ax >>= kx) (ay >>= ky) && e (bx >>= kx) (by >>= ky)+            (ProcessPendingRequests :>>= kx,ProcessPendingRequests :>>= ky) → e (kx ()) (ky ())+            _  → False++{-| For this type, 'mplus' creates a branch node with a choice between two+    subtrees and 'mzero' signifies failure which results in backtracking up the+    tree.+ -}+instance Monad m ⇒ MonadPlus (TreeT m) where+    mzero = TreeT . singleton $ Null+    left `mplus` right = TreeT . singleton $ Choice left right++{-| This instance performs no caching but is provided to make it easier to test+    running a tree using the List monad.+ -}+instance MonadExplorable [] where+    cacheMaybe = maybe mzero return++{-| This instance performs no caching but is provided to make it easier to test+    running a tree using the 'ListT' monad.+ -}+instance Monad m ⇒ MonadExplorable (ListT m) where+    cacheMaybe = maybe mzero return++{-| Like the 'MonadExplorable' instance, this instance does no caching. -}+instance Monad m ⇒ MonadExplorableTrans (ListT m) where+    type NestedMonad (ListT m) = m+    runAndCacheMaybe = lift >=> maybe mzero return++{-| This instance performs no caching but is provided to make it easier to test+    running a tree using the 'Maybe' monad.+ -}+instance MonadExplorable Maybe where+    cacheMaybe = maybe mzero return++{-| This instance performs no caching but is provided to make it easier to test+    running a tree using the 'MaybeT' monad.+ -}+instance Monad m ⇒ MonadExplorable (MaybeT m) where+    cacheMaybe = maybe mzero return++{-| Like the 'MonadExplorable' instance, this instance does no caching. -}+instance Monad m ⇒ MonadExplorableTrans (MaybeT m) where+    type NestedMonad (MaybeT m) = m+    runAndCacheMaybe = lift >=> maybe mzero return++instance Monad m ⇒ MonadExplorable (TreeT m) where+    cache = runAndCache . return+    cacheGuard = runAndCacheGuard . return+    cacheMaybe = runAndCacheMaybe . return+    processPendingRequests = TreeT . singleton $ ProcessPendingRequests++instance Monad m ⇒ MonadExplorableTrans (TreeT m) where+    type NestedMonad (TreeT m) = m+    runAndCache = runAndCacheMaybe . liftM Just+    runAndCacheGuard = runAndCacheMaybe . liftM (\x → if x then Just () else Nothing)+    runAndCacheMaybe = TreeT . singleton . Cache++instance MonadTrans TreeT where+    lift = TreeT . lift++{-| The 'Monoid' instance acts like the 'MonadPlus' instance. -}+instance Monad m ⇒ Monoid (TreeT m α) where+    mempty = mzero+    mappend = mplus+    mconcat = msum++instance Show α ⇒ Show (Tree α) where+    show = s . unwrapTreeT+      where+        s x = case view x of+            Return x → show x+            Null :>>= _ → "<NULL> >>= (...)"+            ProcessPendingRequests :>>= k → "<PPR> >>= " ++ (s . k $ ())+            Cache c :>>= k →+                case runIdentity c of+                    Nothing → "NullCache"+                    Just x → "Cache[" ++ (show . encode $ x) ++ "] >>= " ++ (s (k x))+            Choice (TreeT a) (TreeT b) :>>= k → "(" ++ (s (a >>= k)) ++ ") | (" ++ (s (b >>= k)) ++ ")"+++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++{- $functions+There are three kinds of functions in this module: functions that explore trees+in various ways, functions that make it easier to build trees, and a function+that changes the base monad of a pure tree.+ -}++---------------------------------- Explorers -----------------------------------++{- $runners+The following functions all take a tree as input and produce the result of+exploring it as output. There are seven functions because there are two kinds of+trees --- pure and impure --- and three ways of exploring a tree --- exploring+everything and summing all results (i.e., in the leaves), exploring until the+first result (i.e., in a leaf) is encountered and immediately returning, and+gathering results (i.e., from the leaves) until they satisfy a condition and+then returning --- plus a seventh function that explores a tree only for the+side-effects.+ -}++{-| Explores all the nodes in a pure tree and sums over all the+    results in the leaves.+ -}+exploreTree ::+    Monoid α ⇒+    Tree α {-^ the (pure) tree to be explored -} →+    α {-^ the sum over all results -}+exploreTree v =+    case view (unwrapTreeT v) of+        Return !x → x+        Cache mx :>>= k → maybe mempty (exploreTree . TreeT . k) (runIdentity mx)+        Choice left right :>>= k →+            let !x = exploreTree $ left >>= TreeT . k+                !y = exploreTree $ right >>= TreeT . k+                !xy = mappend x y+            in xy+        Null :>>= _ → mempty+        ProcessPendingRequests :>>= k → exploreTree . TreeT . k $ ()+{-# INLINEABLE exploreTree #-}++{-| Explores all the nodes in an impure tree and sums over all the+    results in the leaves.+ -}+exploreTreeT ::+    (Monad m, Monoid α) ⇒+    TreeT m α {-^ the (impure) tree to be explored -} →+    m α {-^ the sum over all results -}+exploreTreeT = viewT . unwrapTreeT >=> \view →+    case view of+        Return !x → return x+        Cache mx :>>= k → mx >>= maybe (return mempty) (exploreTreeT . TreeT . k)+        Choice left right :>>= k →+            liftM2 (\(!x) (!y) → let !xy = mappend x y in xy)+                (exploreTreeT $ left >>= TreeT . k)+                (exploreTreeT $ right >>= TreeT . k)+        Null :>>= _ → return mempty+        ProcessPendingRequests :>>= k → exploreTreeT . TreeT . k $ ()+{-# SPECIALIZE exploreTreeT :: Monoid α ⇒ Tree α → Identity α #-}+{-# SPECIALIZE exploreTreeT :: Monoid α ⇒ TreeIO α → IO α #-}+{-# INLINEABLE exploreTreeT #-}++{-| Explores a tree for its side-effects, ignoring all results. -}+exploreTreeTAndIgnoreResults ::+    Monad m ⇒+    TreeT m α {-^ the (impure) tree to be explored -} →+    m ()+exploreTreeTAndIgnoreResults = viewT . unwrapTreeT >=> \view →+    case view of+        Return _ → return ()+        Cache mx :>>= k → mx >>= maybe (return ()) (exploreTreeTAndIgnoreResults . TreeT . k)+        Choice left right :>>= k → do+            exploreTreeTAndIgnoreResults $ left >>= TreeT . k+            exploreTreeTAndIgnoreResults $ right >>= TreeT . k+        Null :>>= _ → return ()+        ProcessPendingRequests :>>= k → exploreTreeTAndIgnoreResults . TreeT . k $ ()+{-# SPECIALIZE exploreTreeTAndIgnoreResults :: Tree α → Identity () #-}+{-# SPECIALIZE exploreTreeTAndIgnoreResults :: TreeIO α → IO () #-}+{-# INLINEABLE exploreTreeTAndIgnoreResults #-}++{-| Explores all the nodes in a tree until a result (i.e., a leaf) has been+    found; if a result has been found then it is returned wrapped in 'Just',+    otherwise 'Nothing' is returned.+ -}+exploreTreeUntilFirst ::+    Tree α {-^ the (pure) tree to be explored -} →+    Maybe α {-^ the first result found, if any -}+exploreTreeUntilFirst v =+    case view (unwrapTreeT v) of+        Return x → Just x+        Cache mx :>>= k → maybe Nothing (exploreTreeUntilFirst . TreeT . k) (runIdentity mx)+        Choice left right :>>= k →+            let x = exploreTreeUntilFirst $ left >>= TreeT . k+                y = exploreTreeUntilFirst $ right >>= TreeT . k+            in if isJust x then x else y+        Null :>>= _ → Nothing+        ProcessPendingRequests :>>= k → exploreTreeUntilFirst . TreeT . k $ ()+{-# INLINEABLE exploreTreeUntilFirst #-}++{-| Same as 'exploreTreeUntilFirst', but taking an impure tree instead+    of pure one.+ -}+exploreTreeTUntilFirst ::+    Monad m ⇒+    TreeT m α {-^ the (impure) tree to be explored -} →+    m (Maybe α) {-^ the first result found, if any -}+exploreTreeTUntilFirst = viewT . unwrapTreeT >=> \view →+    case view of+        Return !x → return (Just x)+        Cache mx :>>= k → mx >>= maybe (return Nothing) (exploreTreeTUntilFirst . TreeT . k)+        Choice left right :>>= k → do+            x ← exploreTreeTUntilFirst $ left >>= TreeT . k+            if isJust x+                then return x+                else exploreTreeTUntilFirst $ right >>= TreeT . k+        Null :>>= _ → return Nothing+        ProcessPendingRequests :>>= k → exploreTreeTUntilFirst . TreeT . k $ ()+{-# SPECIALIZE exploreTreeTUntilFirst :: Tree α → Identity (Maybe α) #-}+{-# SPECIALIZE exploreTreeTUntilFirst :: TreeIO α → IO (Maybe α) #-}+{-# INLINEABLE exploreTreeTUntilFirst #-}++{-| Explores all the nodes in a tree, summing all encountered results (i.e., in+    the leaves) until the current partial sum satisfies the condition provided+    by the first function. The returned value is a pair where the first+    component is all of the results that were found during the exploration and+    the second component is 'True' if the exploration terminated early due to+    the condition being met and 'False' otherwise.++    NOTE:  The condition function is assumed to have two properties: first, it+           is assumed to return 'False' for 'mempty', and second, it is assumed+           that if it returns 'True' for @x@ then it also returns 'True' for+           @mappend x y@ and @mappend y x@ for all values @y@.  The reason for+           this is that the condition function is used to indicate when enough+           results have been found, and so it should not be 'True' for 'mempty'+           as nothing has been found and if it is 'True' for @x@ then it should+           not be 'False' for the sum of @y@ with @x@ as this would mean that+           having /more/ than enough results is no longer having enough results.+ -}+exploreTreeUntilFound ::+    Monoid α ⇒+    (α → Bool) {-^ a function that determines when the desired results have been found -} →+    Tree α {-^ the (pure) tree to be explored -} →+    (α,Bool) {-^ the result of the exploration, which includes the results that+                 were found and a flag indicating if they matched the condition+                 function+              -}+exploreTreeUntilFound f v =+    case view (unwrapTreeT v) of+        Return x → (x,f x)+        Cache mx :>>= k →+            maybe (mempty,False) (exploreTreeUntilFound f . TreeT . k)+            $+            runIdentity mx+        Choice left right :>>= k →+            let x@(xr,xf) = exploreTreeUntilFound f $ left >>= TreeT . k+                (yr,yf) = exploreTreeUntilFound f $ right >>= TreeT . k+                zr = xr <> yr+            in if xf then x else (zr,yf || f zr)+        Null :>>= _ → (mempty,False)+        ProcessPendingRequests :>>= k → exploreTreeUntilFound f . TreeT . k $ ()++{-| Same as 'exploreTreeUntilFound', but taking an impure tree instead of+    a pure tree.+ -}+exploreTreeTUntilFound ::+    (Monad m, Monoid α) ⇒+    (α → Bool) {-^ a function that determines when the desired results have been+                   found; it is assumed that this function is 'False' for 'mempty'+                -} →+    TreeT m α {-^ the (impure) tree to be explored -} →+    m (α,Bool) {-^ the result of the exploration, which includes the results+                   that were found and a flag indicating if they matched the+                   condition function+                -}+exploreTreeTUntilFound f = viewT . unwrapTreeT >=> \view →+    case view of+        Return x → return (x,f x)+        Cache mx :>>= k →+            mx+            >>=+            maybe (return (mempty,False)) (exploreTreeTUntilFound f . TreeT . k)+        Choice left right :>>= k → do+            x@(xr,xf) ← exploreTreeTUntilFound f $ left >>= TreeT . k+            if xf+                then return x+                else do+                    (yr,yf) ← exploreTreeTUntilFound f $ right >>= TreeT . k+                    let zr = xr <> yr+                    return (zr,yf || f zr)+        Null :>>= _ → return (mempty,False)+        ProcessPendingRequests :>>= k → exploreTreeTUntilFound f . TreeT . k $ ()++---------------------------------- Builders ------------------------------------++{- $builders+The following functions all create a tree from various inputs.+ -}++{-| Returns a tree (or some other 'MonadPlus') with all of the results in the+    input list.+ -}+allFrom ::+    (Foldable t, Functor t, MonadPlus m) ⇒+    t α {-^ the list (or some other `Foldable`) of results to generate -} →+    m α {-^ a tree that generates the given list of results -}+allFrom = Fold.msum . fmap return+{-# INLINE allFrom #-}++{-| Returns an optimally balanced tree (or some other 'MonadPlus') that+    generates all of the elements in the given (inclusive) range; if the lower+    bound is greater than the upper bound it returns 'mzero'.+ -}+between ::+    (Enum n, MonadPlus m) ⇒+    n {-^ the (inclusive) lower bound of the range -} →+    n {-^ the (inclusive) upper bound of the range -} →+    m n {-^ a tree (or other 'MonadPlus') that generates all the results in the range -}+between x y =+    if a > b+        then mzero+        else go a b+  where+    a = fromEnum x+    b = fromEnum y++    go a b | a == b    = return (toEnum a)+    go a b | otherwise = go a (a+d) `mplus` go (a+d+1) b+      where+        d = (b-a) `div` 2+{-# INLINE between #-}++-------------------------------- Transformers ----------------------------------++{-| This function lets you take a pure tree and transform it into a+    tree with an arbitrary base monad.+ -}+endowTree ::+    Monad m ⇒+    Tree α {-^ the pure tree to transformed into an impure tree -} →+    TreeT m α {-^ the resulting impure tree -}+endowTree tree =+    case view . unwrapTreeT $ tree of+        Return x → return x+        Cache mx :>>= k →+            cacheMaybe (runIdentity mx) >>= endowTree . TreeT . k+        Choice left right :>>= k →+            mplus+                (endowTree left >>= endowTree . TreeT . k)+                (endowTree right >>= endowTree . TreeT . k)+        Null :>>= _ → mzero+        ProcessPendingRequests :>>= k → endowTree . TreeT . k $ ()++--------------------------------------------------------------------------------+------------------------------- Implementation ---------------------------------+--------------------------------------------------------------------------------++{- $implementation+The implementation of the 'Tree' types uses the approach described in \"The+Operational Monad Tutorial\", published in+<http://themonadreader.wordpress.com/ Issue 15 of The Monad.Reader>;+specifically it uses the @operational@ package. The idea is that a list of+instructions are provided in 'TreeTInstruction', and then the operational monad+does all the heavy lifting of turning them into a monad.+ -}++{-| The core of the implementation of 'Tree' is mostly contained in this+    type, which provides a list of primitive instructions for trees:+    'Cache', which caches a value, 'Choice', which signals a branch with two+    choices, 'Null', which indicates that there are no more results, and+    'ProcessPendingRequests', which signals that a break should be taken from+    exploration to process any pending requests (only meant to be used in+    exceptional cases).+ -}+data TreeTInstruction m α where+    Cache :: Serialize α ⇒ m (Maybe α) → TreeTInstruction m α+    Choice :: TreeT m α → TreeT m α → TreeTInstruction m α+    Null :: TreeTInstruction m α+    ProcessPendingRequests :: TreeTInstruction m ()++{-| This is just a convenient alias for working with pure trees. -}+type TreeInstruction = TreeTInstruction Identity
+ sources/LogicGrowsOnTrees/Checkpoint.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}++{-| This module contains the infrastructure used to maintain a checkpoint during+    a tree exploration.+ -}+module LogicGrowsOnTrees.Checkpoint+    (+    -- * Types+      Checkpoint(..)+    , Progress(..)+    -- ** Cursors and contexts+    -- $cursors+    , CheckpointCursor+    , CheckpointDifferential(..)+    , Context+    , ContextStep(..)+    -- ** Exploration state+    , ExplorationTState(..)+    , ExplorationState+    , initialExplorationState+    -- * Exceptions+    , InconsistentCheckpoints(..)+    -- * Utility functions+    -- ** Checkpoint construction+    , checkpointFromContext+    , checkpointFromCursor+    , checkpointFromExplorationState+    , checkpointFromSequence+    , checkpointFromInitialPath+    , checkpointFromUnexploredPath+    , simplifyCheckpointRoot+    , simplifyCheckpoint+    -- ** Path construction+    , pathFromContext+    , pathFromCursor+    , pathStepFromContextStep+    , pathStepFromCursorDifferential+    -- ** Miscelaneous+    , invertCheckpoint+    -- * Stepper functions+    -- $stepper+    , stepThroughTreeStartingFromCheckpoint+    , stepThroughTreeTStartingFromCheckpoint+    -- * Exploration functions+    -- $exploration+    , exploreTreeStartingFromCheckpoint+    , exploreTreeTStartingFromCheckpoint+    , exploreTreeUntilFirstStartingFromCheckpoint+    , exploreTreeTUntilFirstStartingFromCheckpoint+    , exploreTreeUntilFoundStartingFromCheckpoint+    , exploreTreeTUntilFoundStartingFromCheckpoint+    ) where++import Control.Exception (Exception(),throw)+import Control.Monad ((>=>))+import Control.Monad.Operational (ProgramViewT(..),viewT)++import Data.ByteString (ByteString)+import Data.Composition+import Data.Derive.Monoid+import Data.Derive.Serialize+import Data.DeriveTH+import Data.Functor.Identity (Identity,runIdentity)+import Data.Monoid ((<>),Monoid(..))+import Data.Sequence ((|>),Seq,viewr,ViewR(..))+import qualified Data.Sequence as Seq+import Data.Serialize+import Data.Typeable (Typeable)++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Path++--------------------------------------------------------------------------------+--------------------------------- Exceptions -----------------------------------+--------------------------------------------------------------------------------++{-| This exception is thrown when one attempts to merge checkpoints that+    disagree with each other; this will never happen as long as you only merge+    checkpoints that came from the same tree, so if you get this+    exception then there is almost certainly a bug in your code.+ -}+data InconsistentCheckpoints = InconsistentCheckpoints Checkpoint Checkpoint deriving (Eq,Show,Typeable)++instance Exception InconsistentCheckpoints++--------------------------------------------------------------------------------+----------------------------------- Types --------------------------------------+--------------------------------------------------------------------------------++{-| Information about the parts of a tree that have been explored. -}+data Checkpoint =+    CachePoint ByteString Checkpoint+  | ChoicePoint Checkpoint Checkpoint+  | Explored+  | Unexplored+  deriving (Eq,Ord,Read,Show)+$( derive makeSerialize ''Checkpoint )++-- Note:  This function is not in the same place where it appears in the documentation.+{-| Simplifies the root of the checkpoint by replacing++    * @Choicepoint Unexplored Unexplored@ with @Unexplored@;+    +    * @Choicepoint Explored Explored@ with @Explored@; and+    +    * @CachePoint _ Explored@ with @Explored@.+ -}+simplifyCheckpointRoot :: Checkpoint → Checkpoint+simplifyCheckpointRoot (ChoicePoint Unexplored Unexplored) = Unexplored+simplifyCheckpointRoot (ChoicePoint Explored Explored) = Explored+simplifyCheckpointRoot (CachePoint _ Explored) = Explored+simplifyCheckpointRoot checkpoint = checkpoint++{-| The 'Monoid' instance is designed to take checkpoints from two different+    explorations of a given tree and merge them together to obtain a+    checkpoint that indicates /all/ of the areas that have been explored by+    anyone so far. For example, if the two checkpoints are @ChoicePoint Explored+    Unexplored@ and @ChoicePoint Unexplored (ChoicePoint Explored Unexplored)@+    then the result will be @ChoicePoint Explored (ChoicePoint Explored+    Unexplored)@.++    WARNING: This 'Monoid' instance is a /partial/ function that expects+    checkpoints that have come from the /same/ tree; if this+    precondition is not met then if you are lucky it will notice the+    inconsistency and throw an exception to let you know that something is wrong+    and if you are not then it will silently give you a nonsense result. You are+    /very/ unlikely to run into this problem unless for some reason you are+    juggling multiple trees and have mixed up which checkpoint goes with which,+    which is something that is neither done nor encouraged in this package.+ -}+instance Monoid Checkpoint where+    mempty = Unexplored+    Explored `mappend` _ = Explored+    _ `mappend` Explored = Explored+    Unexplored `mappend` x = x+    x `mappend` Unexplored = x+    (ChoicePoint lx rx) `mappend` (ChoicePoint ly ry) =+        simplifyCheckpointRoot (ChoicePoint (lx `mappend` ly) (rx `mappend` ry))+    (CachePoint cx x) `mappend` (CachePoint cy y)+      | cx == cy = simplifyCheckpointRoot (CachePoint cx (x `mappend` y))+    mappend x y = throw (InconsistentCheckpoints x y)++{-| Information about both the current checkpoint and the results we have+    gathered so far.+ -}+data Progress α = Progress+    {   progressCheckpoint :: Checkpoint+    ,   progressResult :: α+    } deriving (Eq,Show)+$( derive makeMonoid ''Progress )+$( derive makeSerialize ''Progress )++instance Functor Progress where+    fmap f (Progress checkpoint result) = Progress checkpoint (f result)++---------------------------- Cursors and contexts ------------------------------++{- $cursors+The types in this subsection are essentially two kinds of zippers for the+'Checkpoint' type; as we explore a tree they represent where we are and how how+to backtrack. The difference between the two types that do this is that, at each+branch, 'Context' keeps around the subtree for the other branch whereas+'CheckpointCursor' does not. The reason for there being two different types is+workload stealing; specifically, when a branch has been stolen from us we want+to forget about its subtree because we are no longer going to explore that+branch ourselves; thus, workload stealing converts 'ContextStep's to+'CheckpointDifferential's. Put another way, as a worker (implemented in+"LogicGrowsOnTrees.Parallel.Common.Worker") explores the tree at all times it+has a 'CheckpointCursor' which tells us about the decisions that it made which+are /frozen/ as we will never backtrack into them to explore the other branch+and a 'Context' which tells us about where we need to backtrack to explore the+rest of the workload assigned to us.+ -}++{-| A zipper that allows us to zoom in on a particular point in the checkpoint. -}+type CheckpointCursor = Seq CheckpointDifferential++{-| The derivative of 'Checkpoint', used to implement the zipper type 'CheckpointCursor'. -}+data CheckpointDifferential =+    CachePointD ByteString+  | ChoicePointD BranchChoice Checkpoint+  deriving (Eq,Read,Show)++{-| Like 'CheckpointCursor', but each step keeps track of the subtree for the+    alternative branch in case we backtrack to it.+ -}+type Context m α = Seq (ContextStep m α)++{-| Like 'CheckpointDifferential', but left branches include the subtree for the+    right branch; the right branches do not need this information because we+    always explore the left branch first.+ -}+data ContextStep m α =+    CacheContextStep ByteString+  | LeftBranchContextStep Checkpoint (TreeT m α)+  | RightBranchContextStep++instance Show (ContextStep m α) where+    show (CacheContextStep c) = "CacheContextStep[" ++ show c ++ "]"+    show (LeftBranchContextStep checkpoint _) = "LeftBranchContextStep(" ++ show checkpoint ++ ")"+    show RightBranchContextStep = "RightRightBranchContextStep"++------------------------------ Exploration state -------------------------------++{- $state+These types contain information about the state of an exploration in progress.+ -}++{-| The current state of the exploration of a tree starting from a checkpoint. -}+data ExplorationTState m α = ExplorationTState+    {   explorationStateContext :: !(Context m α)+    ,   explorationStateCheckpoint :: !Checkpoint+    ,   explorationStateTree :: !(TreeT m α)+    }++{-| An alias for 'ExplorationTState' in a pure setting. -}+type ExplorationState = ExplorationTState Identity++{-| Constructs the initial 'ExplorationTState' for the given tree. -}+initialExplorationState :: Checkpoint → TreeT m α → ExplorationTState m α+initialExplorationState = ExplorationTState Seq.empty++--------------------------------------------------------------------------------+----------------------------- Utility functions --------------------------------+--------------------------------------------------------------------------------++---------------------------- Checkpoint construction ---------------------------++{-| Constructs a full checkpoint given a (context) checkpoint zipper with a hole+    at your current location and the subcheckpoint at your location.+ -}+checkpointFromContext :: Context m α → Checkpoint → Checkpoint+checkpointFromContext = checkpointFromSequence $+    \step → case step of+        CacheContextStep cache → CachePoint cache+        LeftBranchContextStep right_checkpoint _ → flip ChoicePoint right_checkpoint+        RightBranchContextStep → ChoicePoint Explored++{-| Constructs a full checkpoint given a (cursor) checkpoint zipper with a hole+    at your current location and the subcheckpoint at your location.+ -}+checkpointFromCursor :: CheckpointCursor → Checkpoint → Checkpoint+checkpointFromCursor = checkpointFromSequence $+    \step → case step of+        CachePointD cache → CachePoint cache+        ChoicePointD LeftBranch right_checkpoint → flip ChoicePoint right_checkpoint+        ChoicePointD RightBranch left_checkpoint → ChoicePoint left_checkpoint++{-| Computes the current checkpoint given the state of an exploration. -}+checkpointFromExplorationState :: ExplorationTState m α → Checkpoint+checkpointFromExplorationState ExplorationTState{..} =+    checkpointFromContext explorationStateContext explorationStateCheckpoint++{-| Incrementally builds up a full checkpoint given a sequence corresponding to+    some cursor at a particular location of the full checkpoint and the+    subcheckpoint to splice in at that location.++    The main reason that you should use this function is that, as it builds up+    the full checkpoint, it makes some important simplifications via.+    'simplifyCheckpointRoot', such as replacing @ChoicePoint Explored Explored@+    with @Explored@, which both shrinks the size of the checkpoint as well as+    making it /much/ easier to determine if it is equivalent to 'Explored'. + -}+checkpointFromSequence ::+    (α → (Checkpoint → Checkpoint)) →+    Seq α →+    Checkpoint →+    Checkpoint+checkpointFromSequence processStep sequence =+    case viewr sequence of+        EmptyR → id+        rest :> step →+            checkpointFromSequence processStep rest+            .+            simplifyCheckpointRoot+            .+            processStep step++{-| Constructs a full checkpoint given the path to where you are currently+    searching and the subcheckpoint at your location, assuming that we have no+    knowledge of anything outside our location (which is indicated by marking it+    as 'Unexplored').+ -}+checkpointFromInitialPath :: Path → Checkpoint → Checkpoint+checkpointFromInitialPath = checkpointFromSequence $+    \step → case step of+        CacheStep c → CachePoint c+        ChoiceStep LeftBranch → flip ChoicePoint Unexplored+        ChoiceStep RightBranch → ChoicePoint Unexplored++{-| Constructs a full checkpoint given the path to where you are currently+    located, assuming that the current location is 'Unexplored' and everything+    outside of our location has been fully explored already.+ -}+checkpointFromUnexploredPath :: Path → Checkpoint+checkpointFromUnexploredPath path = checkpointFromSequence+    (\step → case step of+        CacheStep c → CachePoint c+        ChoiceStep LeftBranch → flip ChoicePoint Explored+        ChoiceStep RightBranch → ChoicePoint Explored+    )+    path+    Unexplored++{-| Applies 'simplifyCheckpointRoot' everywhere in the checkpoint starting from+    the bottom up.+ -}+simplifyCheckpoint :: Checkpoint → Checkpoint+simplifyCheckpoint (ChoicePoint left right) = simplifyCheckpointRoot (ChoicePoint (simplifyCheckpoint left) (simplifyCheckpoint right))+simplifyCheckpoint (CachePoint cache checkpoint) = simplifyCheckpointRoot (CachePoint cache (simplifyCheckpoint checkpoint))+simplifyCheckpoint checkpoint = checkpoint++------------------------------- Path construction ------------------------------++{-| Computes the path to the current location in the checkpoint as given by the+    context.  (Note that this is a lossy conversation because the resulting path+    does not contain any information about the branches not taken.)+ -}+pathFromContext :: Context m α → Path+pathFromContext = fmap pathStepFromContextStep++{-| Computes the path to the current location in the checkpoint as given by the+    cursor.  (Note that this is a lossy conversation because the resulting path+    does not contain any information about the branches not taken.)+ -}+pathFromCursor :: CheckpointCursor → Path+pathFromCursor = fmap pathStepFromCursorDifferential++{-| Converts a context step to a path step by throwing away information about+    the alternative branch (if present).+ -}+pathStepFromContextStep :: ContextStep m α → Step+pathStepFromContextStep (CacheContextStep cache) = CacheStep cache+pathStepFromContextStep (LeftBranchContextStep _ _) = ChoiceStep LeftBranch+pathStepFromContextStep (RightBranchContextStep) = ChoiceStep RightBranch++{-| Converts a cursor differential to a path step by throwing away information+    about the alternative branch (if present).+ -}+pathStepFromCursorDifferential :: CheckpointDifferential → Step+pathStepFromCursorDifferential (CachePointD cache) = CacheStep cache+pathStepFromCursorDifferential (ChoicePointD active_branch _) = ChoiceStep active_branch++-------------------------------- Miscellaneous ---------------------------------++{-| Inverts a checkpoint so that unexplored areas become explored areas and vice+    versa.  This function satisfies the law that if you sum the result of+    exploring the tree with the original checkpoint and the result of summing+    the tree with the inverted checkpoint then (assuming the result monoid+    commutes) you will get the same result as exploring the entire tree.  That+    is to say,++@+exploreTreeStartingFromCheckpoint checkpoint tree+\<\>+exploreTreeStartingFromCheckpoint (invertCheckpoint checkpoint) tree+==+exploreTree tree+@+ -}+invertCheckpoint :: Checkpoint → Checkpoint+invertCheckpoint Explored = Unexplored+invertCheckpoint Unexplored = Explored+invertCheckpoint (CachePoint cache rest) =+    simplifyCheckpointRoot (CachePoint cache (invertCheckpoint rest))+invertCheckpoint (ChoicePoint left right) =+    simplifyCheckpointRoot (ChoicePoint (invertCheckpoint left) (invertCheckpoint right))++--------------------------------------------------------------------------------+----------------------------- Stepper functions --------------------------------+--------------------------------------------------------------------------------++{- $stepper+The two functions in the in this section are some of the most important+functions in the LogicGrowsOnTrees package, as they provide a means of+incrementally exploring a tree starting from a given checkpoint. The+functionality provided is sufficiently generic that is used by all the various+modes of exploring the tree.+-}++{-| Given the current state of exploration, perform an additional step of+    exploration, returning any solution that was found and the next state of the+    exploration --- which will be 'Nothing' if the entire tree has been+    explored.+ -}+stepThroughTreeStartingFromCheckpoint ::+    ExplorationState α →+    (Maybe α,Maybe (ExplorationState α))+stepThroughTreeStartingFromCheckpoint = runIdentity . stepThroughTreeTStartingFromCheckpoint++{-| Like 'stepThroughTreeStartingFromCheckpoint', but for an impure tree. -}+stepThroughTreeTStartingFromCheckpoint ::+    Monad m ⇒+    ExplorationTState m α →+    m (Maybe α,Maybe (ExplorationTState m α))+stepThroughTreeTStartingFromCheckpoint (ExplorationTState context checkpoint tree) = case checkpoint of+    Explored → return (Nothing, moveUpContext)+    Unexplored → getView >>= \view → case view of+        Return x → return (Just x, moveUpContext)+        Null :>>= _ → return (Nothing, moveUpContext)+        ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))+        Cache mx :>>= k →+            mx >>= return . maybe+                (Nothing, moveUpContext)+                (\x → (Nothing, Just $+                    ExplorationTState+                        (context |> CacheContextStep (encode x))+                        Unexplored+                        (TreeT . k $ x)+                ))+        Choice left right :>>= k → return+            (Nothing, Just $+                ExplorationTState+                    (context |> LeftBranchContextStep Unexplored (right >>= TreeT . k))+                    Unexplored+                    (left >>= TreeT . k)+            )+    CachePoint cache rest_checkpoint → getView >>= \view → case view of+        ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))+        Cache _ :>>= k → return+            (Nothing, Just $+                ExplorationTState+                    (context |> CacheContextStep cache)+                    rest_checkpoint+                    (either error (TreeT . k) . decode $ cache)+            )+        _ → throw PastTreeIsInconsistentWithPresentTree+    ChoicePoint left_checkpoint right_checkpoint →  getView >>= \view → case view of+        ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))+        Choice left right :>>= k → return+            (Nothing, Just $+                ExplorationTState+                    (context |> LeftBranchContextStep right_checkpoint (right >>= TreeT . k))+                    left_checkpoint+                    (left >>= TreeT . k)+            )+        _ → throw PastTreeIsInconsistentWithPresentTree+  where+    getView = viewT . unwrapTreeT $ tree+    moveUpContext = go context+      where+        go context = case viewr context of+            EmptyR → Nothing+            rest_context :> LeftBranchContextStep right_checkpoint right_tree →+                Just (ExplorationTState+                        (rest_context |> RightBranchContextStep)+                        right_checkpoint+                        right_tree+                     )+            rest_context :> _ → go rest_context+{-# INLINE stepThroughTreeTStartingFromCheckpoint #-}++--------------------------------------------------------------------------------+----------------------------- Exploration functions --------------------------------+--------------------------------------------------------------------------------++{- $exploration+The functions in this section explore the remainder of a tree, starting from the+given checkpoint.+-}++{-| Explores the remaining nodes in a pure tree, starting from the+    given checkpoint, and sums over all the results in the leaves.+ -}+exploreTreeStartingFromCheckpoint ::+    Monoid α ⇒+    Checkpoint →+    Tree α →+    α+exploreTreeStartingFromCheckpoint = runIdentity .* exploreTreeTStartingFromCheckpoint++{-| Explores the remaining nodes in an impure tree, starting from the+    given checkpoint, and sums over all the results in the leaves.+ -}+exploreTreeTStartingFromCheckpoint ::+    (Monad m, Monoid α) ⇒+    Checkpoint →+    TreeT m α →+    m α+exploreTreeTStartingFromCheckpoint = go mempty .* initialExplorationState+  where+    go !accum =+        stepThroughTreeTStartingFromCheckpoint+        >=>+        \(maybe_solution,maybe_new_exploration_state) →+            let new_accum = maybe id (flip mappend) maybe_solution accum+            in maybe (return new_accum) (go new_accum) maybe_new_exploration_state+{-# INLINE exploreTreeTStartingFromCheckpoint #-}++{-| Explores all the remaining nodes in a pure tree, starting from the+    given checkpoint, until a result (i.e., a leaf) has been found; if a result+    has been found then it is returned wrapped in 'Just', otherwise 'Nothing' is+    returned.+ -}+exploreTreeUntilFirstStartingFromCheckpoint ::+    Checkpoint →+    Tree α →+    Maybe α+exploreTreeUntilFirstStartingFromCheckpoint = runIdentity .* exploreTreeTUntilFirstStartingFromCheckpoint++{-| Same as 'exploreTreeUntilFirstStartingFromCheckpoint', but for an impure tree. -}+exploreTreeTUntilFirstStartingFromCheckpoint ::+    Monad m ⇒+    Checkpoint →+    TreeT m α →+    m (Maybe α)+exploreTreeTUntilFirstStartingFromCheckpoint = go .* initialExplorationState+  where+    go = stepThroughTreeTStartingFromCheckpoint+         >=>+         \(maybe_solution,maybe_new_exploration_state) →+            case maybe_solution of+                Just _ → return maybe_solution+                Nothing → maybe (return Nothing) go maybe_new_exploration_state+{-# INLINE exploreTreeTUntilFirstStartingFromCheckpoint #-}++{-| Explores all the remaining nodes in a tree, starting from the given checkpoint+    and summing all results encountered (i.e., in the leaves) until the current+    partial sum satisfies the condition provided by the first parameter.++    See 'LogicGrowsOnTrees.exploreTreeUntilFound' for more details.+ -}+exploreTreeUntilFoundStartingFromCheckpoint ::+    Monoid α ⇒+    (α → Bool) →+    Checkpoint →+    Tree α →+    (α,Bool)+exploreTreeUntilFoundStartingFromCheckpoint = runIdentity .** exploreTreeTUntilFoundStartingFromCheckpoint++{-| Same as 'exploreTreeUntilFoundStartingFromCheckpoint', but for an impure tree. -}+exploreTreeTUntilFoundStartingFromCheckpoint ::+    (Monad m, Monoid α) ⇒+    (α → Bool) →+    Checkpoint →+    TreeT m α →+    m (α,Bool)+exploreTreeTUntilFoundStartingFromCheckpoint f = go mempty .* initialExplorationState+  where+    go accum =+        stepThroughTreeTStartingFromCheckpoint+        >=>+        \(maybe_solution,maybe_new_exploration_state) →+            case maybe_solution of+                Nothing → maybe (return (accum,False)) (go accum) maybe_new_exploration_state+                Just solution →+                    let new_accum = accum <> solution+                    in if f new_accum+                        then return (new_accum,True)+                        else maybe (return (new_accum,False)) (go new_accum) maybe_new_exploration_state+{-# INLINE exploreTreeTUntilFoundStartingFromCheckpoint #-}+
+ sources/LogicGrowsOnTrees/Examples/MapColoring.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains examples of logic programs that generate all the valid+    colorings of a given (geographical) map.+ -}+module LogicGrowsOnTrees.Examples.MapColoring where++import Control.Monad (MonadPlus,foldM,forM_,guard,liftM,when)+import Data.Word (Word)++import LogicGrowsOnTrees (between)++{-| Generate all valid map colorings. -}+coloringSolutions ::+    MonadPlus m ⇒+    Word {-^ number of colors -} →+    Word {-^ number of countries -} →+    (Word → Word → Bool) {-^ whether two countries are adjacent (must be symmetric) -} →+    m [(Word,Word)] {-^ a valid coloring -}+coloringSolutions number_of_colors number_of_countries isAdjacentTo =+    foldM addCountryToColoring [] [1..number_of_countries]+  where+    addCountryToColoring coloring country = do+        color ← between 1 number_of_colors+        forM_ coloring $ \(other_country, other_color) →+            when (country `isAdjacentTo` other_country) $+                guard (color /= other_color)+        return $ (country,color):coloring++{-| Generate all /unique/ valid map colorings.  That is, exactly one coloring will+    be generated from each class of colorings that are equivalent under a+    permutation of colors.+ -}+coloringUniqueSolutions ::+    MonadPlus m ⇒+    Word {-^ number of colors -} →+    Word {-^ number of countries -} →+    (Word → Word → Bool) {-^ whether two countries are adjacent (must be symmetric) -} →+    m [(Word,Word)] {-^ a (unique) valid coloring -}+coloringUniqueSolutions number_of_colors number_of_countries isAdjacentTo =+    liftM snd $ foldM addCountryToColoring (0,[]) [1..number_of_countries]+  where+    addCountryToColoring (number_of_colors_used,coloring) country = do+        color ← between 1 ((number_of_colors_used + 1) `min` number_of_colors)+        forM_ coloring $ \(other_country, other_color) →+            when (country `isAdjacentTo` other_country) $+                guard (color /= other_color)+        return (number_of_colors_used `max` color,(country,color):coloring)
+ sources/LogicGrowsOnTrees/Examples/Queens.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains examples of logic programs that generate solutions to the+    n-queens problem, which is the problem of finding ways to put n queens on an+    n x n chessboard in such a way that they do not conflict. Solutions of the+    n-queens problem take the form of a list of n coordinates such that no+    coordinates have overlapping rows, columns, or diagonals (as these are the+    directions in which a queen can attack).+ -}+module LogicGrowsOnTrees.Examples.Queens+    (+    -- * Correct solution counts+      nqueens_correct_counts+    , nqueens_maximum_size+    , nqueensCorrectCount+    -- * Basic examples+    -- $basic++    -- ** Using sets+    -- $sets+    , nqueensUsingSetsSolutions+    , nqueensUsingSetsCount+    -- ** Using bits+    , nqueensUsingBitsSolutions+    , nqueensUsingBitsCount+    -- * Advanced example+    -- $advanced+    , nqueensGeneric+    , nqueensSolutions+    , nqueensCount+    -- * Board size command argument+    , BoardSize(..)+    , makeBoardSizeTermAtPosition+    ) where++import Control.Monad (MonadPlus,guard,liftM)++import Data.Bits ((.|.),(.&.),bit,bitSize,shiftL,shiftR)+import Data.Functor ((<$>))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet) -- imported so that haddock will link to it+import qualified Data.IntSet as IntSet+import Data.Maybe (fromJust)+import Data.Word (Word,Word64)++import System.Console.CmdTheLine++import Text.PrettyPrint (text)++import LogicGrowsOnTrees (Tree,allFrom,exploreTree) -- exploreTree added so that haddock will link to it+import qualified LogicGrowsOnTrees.Examples.Queens.Advanced as Advanced+import LogicGrowsOnTrees.Examples.Queens.Advanced (NQueensSolution,NQueensSolutions,multiplySolution,nqueensGeneric)+import LogicGrowsOnTrees.Utils.Word_+import LogicGrowsOnTrees.Utils.WordSum++--------------------------------------------------------------------------------+---------------------------------- Board size ----------------------------------+--------------------------------------------------------------------------------++{-| This newtype wrapper is used to provide an ArgVal instance that ensure that+    an input board size is between 1 and 'nqueens_maximum_size'.  In general you+    do not need to use this type directly but instead can use the function+    'makeBoardSizeTermAtPosition'.+ -}+newtype BoardSize = BoardSize { getBoardSize :: Word }+instance ArgVal BoardSize where+    converter = (parseBoardSize,prettyBoardSize)+      where+        (parseWord,prettyWord) = converter+        parseBoardSize =+            either Left (\(Word_ n) →+                if n >= 1 && n <= fromIntegral nqueens_maximum_size+                    then Right . BoardSize $ n+                    else Left . text $ "bad board size (must be between 1 and " ++ show nqueens_maximum_size ++ " inclusive)"+            )+            .+            parseWord+        prettyBoardSize = prettyWord . Word_ . getBoardSize+instance ArgVal (Maybe BoardSize) where+    converter = just++{-| This constructs a term for the `cmdtheline` command line parser that expects+    a valid board size (i.e., a number between 1 and 'nqueens_maximum_size') at+    the given positional argument.+ -}+makeBoardSizeTermAtPosition ::+    Int {-^ the position in the commonand line arguments where this argument is expected -} →+    Term Word+makeBoardSizeTermAtPosition position =+    getBoardSize+    <$>+    (required+     $+     pos position+        Nothing+        posInfo+          { posName = "BOARD_SIZE"+          , posDoc = "board size"+          }+    )++--------------------------------------------------------------------------------+-------------------------------- Correct counts --------------------------------+--------------------------------------------------------------------------------++{-| A table with the correct number of solutions for board sizes ranging from 1+    to `nqueens_maximum_size`.++    This data was pulled from <http://queens.inf.tu-dresden.de/?n=f&l=en>.+ -}+nqueens_correct_counts :: IntMap Word+nqueens_correct_counts = IntMap.fromDistinctAscList $+    [( 1,1)+    ,( 2,0)+    ,( 3,0)+    ,( 4,2)+    ,( 5,10)+    ,( 6,4)+    ,( 7,40)+    ,( 8,92)+    ,( 9,352)+    ,(10,724)+    ,(11,2680)+    ,(12,14200)+    ,(13,73712)+    ,(14,365596)+    ,(15,2279184)+    ,(16,14772512)+    ,(17,95815104)+    ,(18,666090624)+    ] ++ if bitSize (undefined :: Int) < 64 then [] else+    [(19,4968057848)+    ,(20,39029188884)+    ,(21,314666222712)+    ,(22,2691008701644)+    ,(23,24233937684440)+    ,(24,227514171973736)+    ,(25,2207893435808352)+    ,(26,22317699616364044)+    ]++{-| The maximum board size in 'nqueens_correct_counts'.  In a 64-bit environment+    this value is equal to the largest board size for which we know the number+    of solutions, which is 26.  In a 32-bit environment this value is equal to+    the largest board size such that the number of solutions fits within a+    32-bit (unsigned) integer (i.e., the range of 'Word'), which is 18.+ -}+nqueens_maximum_size :: Int+nqueens_maximum_size = fst . IntMap.findMax $ nqueens_correct_counts++{-| A /partial function/ that returns the number of solutions for the given+    input board size;  this should only be used when you are sure that the input+    is not greater than 'nqueens_maximum_size'.+ -}+nqueensCorrectCount :: Word → Word+nqueensCorrectCount =+    fromJust+    .+    ($ nqueens_correct_counts)+    .+    IntMap.lookup+    .+    fromIntegral++--------------------------------------------------------------------------------+-------------------------------- Basic examples --------------------------------+--------------------------------------------------------------------------------++{- $basic+The two examples in this section are pretty basic in that they do not make use of+the many optimizations that are available (at the cost of code complexity). The first+example uses set operations, and the second uses bitwise operations.+ -}++---------------------------------- Using sets ----------------------------------++{- $sets+The functions in this subsection use 'IntSet's to keep track of which columns+and diagonals are occupied by queens.  (It is not necessarily to keep track of+occupied rows because the rows are filled consecutively.)+ -}++{-| Generate solutions to the n-queens problem using 'IntSet's. -}+nqueensUsingSetsSolutions :: MonadPlus m ⇒ Word → m NQueensSolution+nqueensUsingSetsSolutions n =+    go n+       0+       (IntSet.fromDistinctAscList [0..fromIntegral n-1])+       IntSet.empty+       IntSet.empty+       []+  where+    go 0 _ _ _ _ !value = return . reverse $ value+    go !n+       !row+       !available_columns+       !occupied_negative_diagonals+       !occupied_positive_diagonals+       !value+     = do+        column ← allFrom $ IntSet.toList available_columns+        let negative_diagonal = row + column+        guard $ IntSet.notMember negative_diagonal occupied_negative_diagonals+        let positive_diagonal = row - column+        guard $ IntSet.notMember positive_diagonal occupied_positive_diagonals+        go (n-1)+           (row+1)+           (IntSet.delete column available_columns)+           (IntSet.insert negative_diagonal occupied_negative_diagonals)+           (IntSet.insert positive_diagonal occupied_positive_diagonals)+           ((fromIntegral row,fromIntegral column):value)+{-# SPECIALIZE nqueensUsingSetsSolutions :: Word → NQueensSolutions #-}+{-# SPECIALIZE nqueensUsingSetsSolutions :: Word → Tree NQueensSolution #-}+{-# INLINEABLE nqueensUsingSetsSolutions #-}++{-| Generates the solution count to the n-queens problem with the given board+    size;  you need to sum over all these counts to obtain the total, which is+    done by the 'exploreTree' (and related) functions.+ -}+nqueensUsingSetsCount :: MonadPlus m ⇒ Word → m WordSum+nqueensUsingSetsCount = liftM (const $ WordSum 1) . nqueensUsingSetsSolutions+{-# SPECIALIZE nqueensUsingSetsCount :: Word → [WordSum] #-}+{-# SPECIALIZE nqueensUsingSetsCount :: Word → Tree WordSum #-}+{-# INLINEABLE nqueensUsingSetsCount #-}++---------------------------------- Using bits ----------------------------------++{- $bits+A basic optimization that results in a signiciant performance improvements is to+use 'Word64's as set implemented using bitwise operations --- that is, a bit in+position 1 means that column 1 / negative diagonal 1 / positive diagnal 1 is+occupied.  The total occupied positions can be obtained by taking the bitwise or+of the occupied columns, positive diagonals, and negative diagonals.++Note that when we go to the next row, we shift the negative diagonals right and+the positive diagonals left as every negative/positive diagonal that contains a+square at a given row and column also contains column (x+1)/(x-1) of the+succeeding row.+ -}++{-| Generate solutions to the n-queens problem using bitwise-operations. -}+nqueensUsingBitsSolutions :: MonadPlus m ⇒ Word → m NQueensSolution+nqueensUsingBitsSolutions n =+    go n 0 (0::Word64) (0::Word64) (0::Word64) []+  where+    go 0 _ _ _ _ !value = return . reverse $ value+    go !n+       !row+       !occupied_columns+       !occupied_negative_diagonals+       !occupied_positive_diagonals+       !value+     = do+        column ← allFrom . goGetOpenings 0 $+            occupied_columns .|. +            occupied_negative_diagonals .|.+            occupied_positive_diagonals+        let column_bit = bit (fromIntegral column)+        go (n-1)+           (row+1)+           (occupied_columns .|. column_bit)+           ((occupied_negative_diagonals .|. column_bit) `shiftR` 1)+           ((occupied_positive_diagonals .|. column_bit) `shiftL` 1)+           ((row,column):value)++    goGetOpenings column bits+      | column >= n     = []+      | bits .&. 1 == 0 = column:next+      | otherwise       = next+      where+        next = goGetOpenings (column + 1) (bits `shiftR` 1)+{-# SPECIALIZE nqueensUsingBitsSolutions :: Word → NQueensSolutions #-}+{-# SPECIALIZE nqueensUsingBitsSolutions :: Word → Tree NQueensSolution #-}+{-# INLINEABLE nqueensUsingBitsSolutions #-}++{-| Generates the solution count to the n-queens problem with the given board+    size;  you need to sum over all these counts to obtain the total, which is+    done by the 'exploreTree' (and related) functions.+ -}+nqueensUsingBitsCount :: MonadPlus m ⇒ Word → m WordSum+nqueensUsingBitsCount = liftM (const $ WordSum 1) . nqueensUsingBitsSolutions+{-# SPECIALIZE nqueensUsingBitsCount :: Word → [WordSum] #-}+{-# SPECIALIZE nqueensUsingBitsCount :: Word → Tree WordSum #-}+{-# INLINEABLE nqueensUsingBitsCount #-}++--------------------------------------------------------------------------------+------------------------------- Advanced example -------------------------------+--------------------------------------------------------------------------------++{- $advanced+The advanced example use several techniques to try and squeeze out as much+performance as possible using the functionality of this package. The functions+listed here are just the interface to it; for the implementation driving these+functions, see the "LogicGrowsOnTrees.Examples.Queens.Advanced" module.+ -}++{-| Generates the solutions to the n-queens problem with the given board size. -}+nqueensSolutions :: MonadPlus m ⇒ Word → m NQueensSolution+nqueensSolutions n = nqueensGeneric (++) multiplySolution [] n+{-# SPECIALIZE nqueensSolutions :: Word → NQueensSolutions #-}+{-# SPECIALIZE nqueensSolutions :: Word → Tree NQueensSolution #-}++{-| Generates the solution count to the n-queens problem with the given board+    size;  you need to sum over all these counts to obtain the total, which is+    done by the 'exploreTree' (and related) functions.+ -}+nqueensCount :: MonadPlus m ⇒ Word → m WordSum+nqueensCount = nqueensGeneric (const id) (\_ symmetry _ → return . WordSum . Advanced.multiplicityForSymmetry $ symmetry) ()+{-# SPECIALIZE nqueensCount :: Word → [WordSum] #-}+{-# SPECIALIZE nqueensCount :: Word → Tree WordSum #-}+
+ sources/LogicGrowsOnTrees/Examples/Queens/Advanced.hs view
@@ -0,0 +1,1341 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++{-|+This module contains a heavily optimized solver for the n-queens problems.+Specifically, it uses the following tricks:++  * symmetry breaking to prune redundant solutions++  * unpacked datatypes instead of multiple arguments++  * optimized 'getOpenings'++  * C code for the inner-most loop++  * @INLINE@s in many places in order to create optimized specializations of+    the generic functions++Benchmarks were used to determine that all of these tricks resulted in+performance improvements using GHC 7.4.3.+ -}+module LogicGrowsOnTrees.Examples.Queens.Advanced+    (+    -- * Types+      NQueensSymmetry(..)+    , NQueensSolution+    , NQueensSolutions+    , PositionAndBit+    , PositionAndBitWithReflection+    -- * Main algorithm+    , nqueensGeneric+    -- ** Symmetry breaking+    -- $symmetry-breaking+    , nqueensStart+    , NQueensBreak90State(..)+    , nqueensBreak90+    , NQueensBreak180State(..)+    , nqueensBreak180+    -- ** Brute-force search+    -- $brute-force+    , NQueensSearchState(..)+    , nqueensSearch+    , nqueensBruteForceGeneric+    , nqueensBruteForceSolutions+    , nqueensBruteForceCount+    -- ** C inner-loop+    , c_LogicGrowsOnTrees_Queens_count_solutions+    , mkPushValue+    , mkPopValue+    , mkFinalizeValue+    , nqueensCSearch+    , nqueensCGeneric+    , nqueensCSolutions+    , nqueensCCount+    -- * Helper functions+    , allRotationsAndReflectionsOf+    , allRotationsOf+    , convertSolutionToWord+    , extractExteriorFromSolution+    , getOpenings+    , getSymmetricOpenings+    , hasReflectionSymmetry+    , hasRotate90Symmetry+    , hasRotate180Symmetry+    , multiplicityForSymmetry+    , multiplySolution+    , reflectBits+    , reflectSolution+    , rotate180+    , rotateLeft+    , rotateRight+    , symmetryOf+    ) where++import Control.Applicative ((<$>),liftA2)+import Control.Arrow ((***))+import Control.Exception (evaluate)+import Control.Monad (MonadPlus(..),(>=>),liftM,liftM2)++import Data.Bits ((.&.),(.|.),bit,rotateL,rotateR,unsafeShiftL,unsafeShiftR)+import Data.Function (on)+import Data.IORef (modifyIORef,newIORef,readIORef,writeIORef)+import Data.List (sort)+import Data.Maybe (fromJust)+import Data.Typeable (Typeable(..),cast)+import Data.Word (Word,Word64)++import Foreign.C.Types (CUInt(..))+import Foreign.Ptr (FunPtr,freeHaskellFunPtr,nullFunPtr)++import System.IO.Unsafe (unsafePerformIO)++import LogicGrowsOnTrees (Tree,between)+import LogicGrowsOnTrees.Utils.WordSum++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++{-| The possible board symmetries. -}+data NQueensSymmetry =+    NoSymmetries {-^ the board has no symmetries at all -}+  | Rotate180Only {-^ the board is symmetric under 180 degree rotations -}+  | AllRotations {-^ the board is symmetric under all rotations -}+  | AllSymmetries {-^ the board is symmetric under all rotations and reflections -}+  deriving (Eq,Ord,Read,Show)++{-| Type alias for a solution, which takes the form of a list of coordinates. -}+type NQueensSolution = [(Word,Word)]++{-| Type alias for a list of solutions. -}+type NQueensSolutions = [NQueensSolution]++{-| Represents a position and bit at that position. -}+data PositionAndBit = PositionAndBit {-# UNPACK #-} !Int {-# UNPACK #-} !Word64++{-| Like 'PositionAndBit', but also including the same for the reflection of the+    position (i.e., one less than the board size minus the position).+ -}+data PositionAndBitWithReflection = PositionAndBitWithReflection {-# UNPACK #-} !Int {-# UNPACK #-} !Word64  {-# UNPACK #-} !Int {-# UNPACK #-} !Word64++--------------------------------------------------------------------------------+-------------------------------- Main algorithm --------------------------------+--------------------------------------------------------------------------------++-- NOTE:  the spaces before 'Typeable' are needed due to a haddock glitch+{-| Interface to the main algorithm;  note that α and β need to be   'Typeable'+    because of an optimization used in the C part of the code. This function+   takes functions for its first two operators that operate on partial solutions+   so that the same algorithm can be used both for generating solutions and+   counting them; the advantage of this approach is that it is much easier to+   find problems in the generated solution than it is in their count, so we can+   test it by looking for problems in the generated solutions, and when we are+   assured that it works we can trust it to obtain the correct counts.+ -}+nqueensGeneric ::+    (MonadPlus m+    ,Typeable α+    ,Typeable β+    ) ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solution -} →+    (Word → NQueensSymmetry → α → m β) {-^ function that finalizes a partial solution with the given board size and symmetry -} →+    α {-^ initial partial solution -} →+    Word {-^ board size -} →+    m β {-^ the final result -}+nqueensGeneric updateValue finalizeValueWithSymmetry initial_value 1 =+    finalizeValueWithSymmetry 1 AllSymmetries . updateValue [(0,0)] $ initial_value+nqueensGeneric _ _ _ 2 = mzero+nqueensGeneric _ _ _ 3 = mzero+nqueensGeneric updateValue finalizeValueWithSymmetry initial_value n =+    nqueensStart+        updateValue+        break90+        break180+        search+        initial_value+        n+  where+    break90 = nqueensBreak90 updateValue (finalizeValueWithSymmetry n AllRotations) break90 break180 search+    break180 = nqueensBreak180 updateValue (finalizeValueWithSymmetry n Rotate180Only) break180 search+    search value size state = nqueensSearch updateValue (finalizeValueWithSymmetry n NoSymmetries) value size state+{-# INLINE nqueensGeneric #-}++--------------------------------------------------------------------------------+------------------------------ Symmetry-breaking -------------------------------+--------------------------------------------------------------------------------++{- $symmetry-breaking+A performance gain can be obtained by factoring out symmetries because if, say,+a solution has rotational symmetry, then that means that there are four+configurations that are equivalent, and so we would ideally like to prune three+of these four equivalent solutions.++I call the approach used here "symmetry breaking". The idea is we start with a+perfectly symmetrical board (as it has nothing on it) and then we work our way+from the outside in. We shall use the term /layer/ to refer to a set of board+positions that form a centered (hollow) square on the board, so the outermost+layer is the set of all positions at the boundary of the board, the next layer+in is the square just nested in the outermost layer, and so in. At each step we+either preserve a given symmetry for the current layer or we break it; in the+former case we stay within the current routine to try to break it in the next+layer in, in the latter case we jump to a routine designed to break the new+symmetry in the next layer in. When all symmetries have been broken, we jump to+the brute-force search code. If we place all of the queens while having+preserved one or more symmetries, then either we apply the rotations and+reflections of the symmetry to generate all of the solutions or we multiply the+solution count by the number of equivalent solutions.++This code is unforunately quite complicated because there are many possibilities+for how to break or not break the symmetries and at each step it has to place+between 0 and 4 queens in such a way as to not conflict with any queen that has+already been placed.++Each function takes callbacks for each symmetry rather than directly calling+'nqueensBreak90', etc. in order to ease testing.++-}++-------------------------------- All symmeties ---------------------------------++{-| Break the reflection symmetry. -}+nqueensStart ::+    MonadPlus m ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → NQueensBreak90State → m β) {-^ function to break the rotational symmetry for the next inner layer -} →+    (α → NQueensBreak180State → m β) {-^ function to break the 180-degree rotational symmetry for the next inner layer -} →+    (α → Int → NQueensSearchState → m β) {-^ function to apply a brute-force search -} →+    α {-^ partial solution -} →+    Word {-^ board size -} →+    m β {-^ the final result -}+nqueensStart+  !updateValue_+  !break90+  !break180+  !search+  !value+  !n = (preserve90 `mplus` breakTo180) `mplus` (breakAtCorner `mplus` breakAtSides)+  where+    updateValue = updateValue_ . convertSolutionToWord+    half_inner_size = fromIntegral $ (n `div` 2) - 1+    last = fromIntegral $ n-1+    inner_last = last-1++    -- break to 90-degree rotational symmetry+    preserve90 = do+        position ← between 1 half_inner_size+        let reflected_position = last-position+            occupied_bits = bit position .|. bit reflected_position+        break90+            (updateValue+                [(position,last)+                ,(last,reflected_position)+                ,(reflected_position,0)+                ,(0,position)+                ]+                value+            )+            (NQueensBreak90State+                (n-4)+                 1+                (fromIntegral $ n-2)+                (occupied_bits `unsafeShiftR` 1)+                ((occupied_bits .|. (occupied_bits `unsafeShiftL` last)) `unsafeShiftR` 2)+                 (occupied_bits .|. (occupied_bits `rotateR` last))+            )++    -- break to 180-degree rotational symmetry+    breakTo180 = do+        top_column ← between 1 half_inner_size+        right_row ←+            if n .&. 1 == 0+                then between (top_column+1) (last-(top_column+1))+                else between (top_column+1) half_inner_size `mplus`+                     between (half_inner_size+2) (last-(top_column+1))+        let bottom_column = last-top_column+            left_row = last-right_row+            top_column_bit = bit top_column+            right_row_bit = bit right_row+            bottom_column_bit = bit bottom_column+            left_row_bit = bit left_row+        break180+            (updateValue+                [(left_row,last)+                ,(last,bottom_column)+                ,(right_row,0)+                ,(0,top_column)+                ]+                value+            )+            (NQueensBreak180State+                (n-4)+                 1+                (fromIntegral $ n-2)+                ((right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+                ((top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+                ((top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` last)) `unsafeShiftR` 2)+                 (top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `rotateR` last))+                 (right_row_bit .|. top_column_bit)+            )++    -- break all symmetries by placing a queen at a corner+    breakAtCorner = do+        left_row ← between 1 (inner_last-1)+        bottom_column ← between (left_row+1) inner_last+        let left_row_bit = bit left_row+            reflected_left_row_bit = bit (last-left_row)+            bottom_column_bit = bit bottom_column+        search+            (updateValue+                [(last,bottom_column)+                ,(left_row,last)+                ,(0,0)+                ]+                value+            )+            (fromIntegral $ n-2)+            (NQueensSearchState+                (n-3)+                 1+                (left_row_bit `unsafeShiftR` 1)+                (bottom_column_bit `unsafeShiftR` 1)+                ((left_row_bit .|. bottom_column_bit) `unsafeShiftL` (last-2))+                (1 .|. reflected_left_row_bit .|. (bottom_column_bit `rotateR` last))+            )++    -- break all symmetries without placing a queen at a corner+    breakAtSides = do+        top_column ← between 1 half_inner_size+        let reflected_top_column = last-top_column+            after_top_column = top_column+1+            reflected_after_top_column = reflected_top_column-1+        right_row ← between after_top_column reflected_after_top_column+        let reflected_right_row = last-right_row+        bottom_column ←+            between after_top_column (reflected_right_row-1) `mplus`+            between (reflected_right_row+1) reflected_top_column+        left_row ←+            if bottom_column == reflected_top_column+                then if reflected_right_row < right_row+                        then between top_column (reflected_right_row-1)+                        else between top_column (right_row-1) `mplus`+                             between (right_row+1) (reflected_right_row-1)+                else let (first,second)+                           | right_row < bottom_column = (right_row,bottom_column)+                           | otherwise                 = (bottom_column,right_row)+                     in  between top_column (first-1) `mplus`+                         between (first+1) (second-1) `mplus`+                         between (second+1) reflected_after_top_column+        let top_column_bit = bit top_column+            right_row_bit = bit right_row+            bottom_column_bit = bit bottom_column+            left_row_bit = bit left_row+        search+            (updateValue+                [(left_row,last)+                ,(last,bottom_column)+                ,(right_row,0)+                ,(0,top_column)+                ]+                value+            )+            (fromIntegral $ n-2)+            (NQueensSearchState+                (n-4)+                 1+                ((left_row_bit .|. right_row_bit) `unsafeShiftR` 1)+                ((top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+                ((top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` last)) `unsafeShiftR` 2)+                 (top_column_bit .|. bit (last-left_row) .|. (1 `rotateR` right_row) .|. (bottom_column_bit `rotateR` last))+            )++------------------------ 90-degree rotational symmetry -------------------------++{-| The state type while the 90-degree rotational symmetry is being broken. -}+data NQueensBreak90State = NQueensBreak90State+    {   b90_number_of_queens_remaining :: {-# UNPACK #-} !Word+    ,   b90_window_start :: {-# UNPACK #-} !Int+    ,   b90_window_size :: {-# UNPACK #-} !Int+    ,   b90_occupied_rows_and_columns :: {-# UNPACK #-} !Word64+    ,   b90_occupied_negative_diagonals :: {-# UNPACK #-} !Word64+    ,   b90_occupied_positive_diagonals :: {-# UNPACK #-} !Word64+    }++{-| Break the 90-degree rotational symmetry at the current layer. -}+nqueensBreak90 ::+    MonadPlus m ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    (α → NQueensBreak90State → m β) {-^ function to break the rotational symmetry for the next inner layer -} →+    (α → NQueensBreak180State → m β) {-^ function to break the 180-degree rotational symmetry for the next inner layer -} →+    (α → Int → NQueensSearchState → m β) {-^ function to apply a brute-force search -} →+    α {-^ partial solution -} →+    NQueensBreak90State {-^ current state -} →+    m β {-^ the final result -}+nqueensBreak90+  !updateValue_+  !finalizeValue+  !break90+  !break180+  !search+  !value+  !(NQueensBreak90State+      number_of_queens_remaining+      window_start+      window_size+      occupied_rows_and_columns+      occupied_negative_diagonals+      occupied_positive_diagonals+  )+  | number_of_queens_remaining == 0 = finalizeValue value+  | window_size > 3 =+     if occupied_rows_and_columns .&. 1 == 0+        then keep90 `mplus` breakTo180 `mplus`+                if occupied_negative_diagonals .&. 1 == 0+                    then breakAtCorner `mplus` breakAtSides+                    else breakAtSides+        else nextWindow+  | number_of_queens_remaining == 1 && occupied_rows_and_columns .&. 2 == 0 =+     finalizeValue ([(window_start+1,window_start+1)] `updateValue` value)+  | otherwise = mzero+  where+    updateValue = updateValue_ . convertSolutionToWord+    window_end = window_start+window_size-1+    end = window_size-1+    inner_size = window_size-2+    inner_end = window_size-3+    blocked = occupied_rows_and_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals+    inner_blocked = blocked `unsafeShiftR` 1+    inner_blocked_excluding_middle+      | window_size .&. 1 == 0 = inner_blocked+      | otherwise = inner_blocked .|. bit (inner_size `div` 2)++    -- place queens to preserve all rotational symmetries+    keep90 = do+        PositionAndBitWithReflection offset offset_bit reflected_offset reflected_offset_bit ←+            getSymmetricOpenings inner_size inner_blocked_excluding_middle+        let position = window_start+offset+1+            reflected_position = window_start+reflected_offset+1+            occupied_bits = (offset_bit .|. reflected_offset_bit) `unsafeShiftL` 1+        break90+            (updateValue+                [(position,window_end)+                ,(window_end,reflected_position)+                ,(reflected_position,window_start)+                ,(window_start,position)+                ]+                value+            )+            (NQueensBreak90State+                (number_of_queens_remaining-4)+                (window_start+1)+                (window_size-2)+                ((occupied_rows_and_columns .|. occupied_bits) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. occupied_bits .|. (occupied_bits `unsafeShiftL` end)) `unsafeShiftR` 2)+                 (occupied_positive_diagonals .|. occupied_bits .|. (occupied_bits `rotateR` end))+            )++    -- place queens to break down to 180-degree rotational symmetry+    breakTo180 = do+        PositionAndBit inner_top_column inner_top_column_bit ←+            getOpenings (inner_size-1) inner_blocked_excluding_middle+        PositionAndBit inner_right_row _ ←+            getOpenings (inner_end-inner_top_column) (inner_blocked_excluding_middle .|. inner_top_column_bit)+        let top_column = inner_top_column+1+            bottom_column = end-top_column+            right_row = inner_right_row+1+            left_row = end-right_row+            top_column_bit = bit top_column+            bottom_column_bit = bit bottom_column+            right_row_bit = bit right_row+            left_row_bit = bit left_row+            new_occupied_positive_diagonals = occupied_positive_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `rotateR` end)+        break180+            (updateValue+               [(window_start+left_row,window_end)+               ,(window_end,window_start+bottom_column)+               ,(window_start+right_row,window_start)+               ,(window_start,window_start+top_column)+               ]+               value+            )+            (NQueensBreak180State+                (number_of_queens_remaining-4)+                (window_start+1)+                (window_size-2)+                ((occupied_rows_and_columns .|. right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+                ((occupied_rows_and_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` end)) `unsafeShiftR` 2)+                 new_occupied_positive_diagonals+                (reflectBits new_occupied_positive_diagonals)+            )++    -- fully break all symmetries by placing a queen at a corner+    breakAtCorner = do+        PositionAndBit inner_left_row inner_left_row_bit ←+            getOpenings inner_size inner_blocked+        PositionAndBit inner_bottom_column _ ←+            getOpenings inner_size (inner_blocked .|. inner_left_row_bit)+        let left_row = inner_left_row+1+            bottom_column = inner_bottom_column+1                +            left_row_bit = bit left_row+            reflected_left_row_bit = bit (end-left_row)+            bottom_column_bit = bit bottom_column+        search+            (updateValue+                [(window_end,window_start+bottom_column)+                ,(window_start+left_row,window_end)+                ,(window_start,window_start)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-3)+                (window_start+1)+                ((occupied_rows_and_columns .|. left_row_bit) `unsafeShiftR` 1)+                ((occupied_rows_and_columns .|. bottom_column_bit) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. ((left_row_bit .|. bottom_column_bit) `unsafeShiftL` end)) `unsafeShiftR` 2)+                 (occupied_positive_diagonals .|. 1 .|. reflected_left_row_bit .|. (bottom_column_bit `rotateR` end))+            )++    -- fully break all symmetries placing no queens at a corner+    breakAtSides = do+        PositionAndBit inner_top_column _ ←+            getOpenings (inner_size-1) inner_blocked+        let inner_reflected_top_column = inner_end-inner_top_column+            inner_reflected_top_column_bit = bit inner_reflected_top_column+            size_of_space_above_inner_top_column = inner_end-inner_top_column+            size_of_space_above_and_including_inner_top_column = size_of_space_above_inner_top_column + 1+            shift_to_inner_top_column = inner_top_column+            shift_to_just_past_inner_top_column = inner_top_column+1+        PositionAndBit inner_right_offset _ ←+            getOpenings+                size_of_space_above_inner_top_column+                ((inner_blocked .|. bit inner_reflected_top_column) `unsafeShiftR` shift_to_just_past_inner_top_column)+        let inner_reflected_right_row = inner_right_offset + inner_top_column + 1+            inner_right_row = inner_end - inner_reflected_right_row +        PositionAndBit inner_bottom_offset _ ←+            getOpenings+                size_of_space_above_and_including_inner_top_column+                ((inner_blocked .|. inner_reflected_top_column_bit .|. bit inner_right_row) `unsafeShiftR` shift_to_inner_top_column)+        let inner_bottom_column = inner_end - (inner_bottom_offset + inner_top_column)+        PositionAndBit inner_left_row_offset _ ←+            getOpenings+                (if inner_bottom_offset > 0+                    then size_of_space_above_and_including_inner_top_column+                    else inner_reflected_right_row-inner_top_column+                )+                ((inner_blocked .|. bit inner_right_row .|. bit inner_bottom_column .|. inner_reflected_top_column_bit) `unsafeShiftR` shift_to_inner_top_column)+        let top_column = inner_top_column + 1+            right_row = inner_right_row + 1+            bottom_column = inner_bottom_column + 1+            left_row = inner_left_row_offset + inner_top_column + 1+            top_column_bit = bit top_column+            right_row_bit = bit right_row+            bottom_column_bit = bit bottom_column+            left_row_bit = bit left_row+        search+            (updateValue+                [(window_start+left_row,window_end)+                ,(window_end,window_start+bottom_column)+                ,(window_start+right_row,window_start)+                ,(window_start,window_start+top_column)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-4)+                (window_start+1)+                ((occupied_rows_and_columns .|. left_row_bit .|. right_row_bit) `unsafeShiftR` 1)+                ((occupied_rows_and_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` end)) `unsafeShiftR` 2)+                 (occupied_positive_diagonals .|. top_column_bit .|. bit (end-left_row) .|. (1 `rotateR` right_row) .|. (bottom_column_bit `rotateR` end))+            )++    -- all squares in this layer are occupied, go to the next one+    nextWindow = break90 value $+        NQueensBreak90State+             number_of_queens_remaining+            (window_start+1)+            (window_size-2)+            (occupied_rows_and_columns `unsafeShiftR` 1)+            (occupied_negative_diagonals `unsafeShiftR` 2)+             occupied_positive_diagonals++----------------------- 180-degree rotational symmetry -------------------------++{-| The state while the 180-degree rotational symmetry is being broken. -}+data NQueensBreak180State = NQueensBreak180State+    {   b180_number_of_queens_remaining :: {-# UNPACK #-} !Word+    ,   b180_window_start :: {-# UNPACK #-} !Int+    ,   b180_window_size :: {-# UNPACK #-} !Int+    ,   b180_occupied_rows :: {-# UNPACK #-} !Word64+    ,   b180_occupied_columns :: {-# UNPACK #-} !Word64+    ,   b180_occupied_negative_diagonals :: {-# UNPACK #-} !Word64+    ,   b180_occupied_positive_diagonals :: {-# UNPACK #-} !Word64+    ,   b180_occupied_right_positive_diagonals :: {-# UNPACK #-} !Word64+    }++{-| Break the 180-degree rotational symmetry at the current layer. -}+nqueensBreak180 ::+    MonadPlus m ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    (α → NQueensBreak180State → m β) {-^ function to break the 180-degree rotational symmetry for the next inner layer -} →+    (α → Int → NQueensSearchState → m β) {-^ function to apply a brute-force search -} →+    α {-^ partial solution -} →+    NQueensBreak180State {-^ current state -} →+    m β {-^ the final result -}+nqueensBreak180+  !updateValue_+  !finalizeValue+  !break180+  !search+  !value+  !(NQueensBreak180State+      number_of_queens_remaining+      window_start+      window_size+      occupied_rows+      occupied_columns+      occupied_negative_diagonals+      occupied_positive_diagonals+      occupied_right_positive_diagonals+  )+  | number_of_queens_remaining == 0 = finalizeValue value+  | window_size > 3 =+     if occupied_rows .&. 1 == 0+        then if occupied_columns .&. 1 == 0+                then mplus preserve180 $+                    if occupied_negative_diagonals .&. end_bit .|. occupied_positive_diagonals .&. end_bit == 0+                        then if occupied_negative_diagonals .&. bit (2*end) .|. occupied_positive_diagonals .&. 1 == 0+                                then breakAtBottomLeftCorner `mplus` breakAtTopLeftCorner `mplus` breakAtSides+                                else breakAtTopLeftCorner `mplus` breakAtSides+                        else if occupied_negative_diagonals .&. bit (2*end) .|. occupied_positive_diagonals .&. 1 == 0+                                then breakAtBottomLeftCorner `mplus` breakAtSides+                                else breakAtSides+                else preserve180Horizontal `mplus` breakAtHorizontalSides+        else if occupied_columns .&. 1 == 0+                then preserve180Vertical `mplus` breakAtVerticalSides+                else nextWindow+  | number_of_queens_remaining == 1 && (occupied_rows .|. occupied_columns) .&. 2 == 0 =+     finalizeValue ([(window_start+1,window_start+1)] `updateValue` value)+  | otherwise = mzero+  where+    updateValue = updateValue_ . convertSolutionToWord+    end = window_size-1+    end_bit = bit end+    window_end = window_start+end+    inner_size = window_size-2+    inner_end = window_size-3+    horizontal_blocked = occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals+    inner_horizontal_blocked = horizontal_blocked `unsafeShiftR` 1+    inner_horizontal_blocked_excluding_middle+      | window_size .&. 1 == 0 = inner_horizontal_blocked+      | otherwise = inner_horizontal_blocked .|. bit (window_size `div` 2 - 1)+    vertical_blocked = occupied_rows .|. occupied_negative_diagonals .|. occupied_right_positive_diagonals+    inner_vertical_blocked = vertical_blocked `unsafeShiftR` 1+    inner_vertical_blocked_excluding_middle+      | window_size .&. 1 == 0 = inner_vertical_blocked+      | otherwise = inner_vertical_blocked .|. bit (window_size `div` 2 - 1)++    -- break the symmetry without placing a queen at a corner+    breakAtSides = do+        PositionAndBit inner_top_column inner_top_column_bit ←+            getOpenings+                inner_size+                inner_horizontal_blocked+        let inner_reflected_top_column_bit = bit (inner_end - inner_top_column)+        PositionAndBit inner_right_row inner_right_row_bit ←+            getOpenings+                inner_size+               (inner_vertical_blocked .|. inner_top_column_bit)+        PositionAndBit inner_reflected_bottom_column_offset _ ←+            getOpenings+               (inner_end-inner_top_column+1)+              ((inner_horizontal_blocked .|. inner_reflected_top_column_bit .|. inner_right_row_bit) `unsafeShiftR` inner_top_column)+        let inner_reflected_bottom_column = inner_top_column + inner_reflected_bottom_column_offset+            inner_reflected_bottom_column_bit = bit inner_reflected_bottom_column+        PositionAndBit inner_reflected_left_row _ ←+            getOpenings+                (if inner_reflected_bottom_column_offset > 0+                    then inner_size+                    else inner_right_row+                )+                (inner_vertical_blocked .|. bit (inner_end - inner_right_row) .|. inner_reflected_bottom_column_bit .|. inner_top_column_bit)+        let top_column = inner_top_column + 1+            top_column_bit = bit top_column+            right_row = inner_right_row + 1+            right_row_bit = bit right_row+            reflected_right_row_bit = bit (end-right_row)+            bottom_column = inner_end - inner_reflected_bottom_column + 1+            bottom_column_bit = bit bottom_column+            left_row = inner_end - inner_reflected_left_row + 1+            left_row_bit = bit left_row+            reflected_left_row_bit = bit (end-left_row)+        search+            (updateValue+                [(window_start+left_row,window_end)+                ,(window_end,window_start+bottom_column)+                ,(window_start+right_row,window_start)+                ,(window_start,window_start+top_column)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-4)+                (window_start+1)+               ((occupied_rows .|. right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+               ((occupied_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. top_column_bit .|. reflected_left_row_bit .|. ((bottom_column_bit .|. reflected_right_row_bit) `rotateR` end))+            )++    -- break the symmetry by placing queens only on the horizontal sides+    breakAtHorizontalSides = do+        PositionAndBit inner_top_column _ ←+            getOpenings+               (inner_size-1)+                inner_horizontal_blocked+        PositionAndBit inner_reflected_bottom_column_offset _ ←+            getOpenings+               (inner_end-inner_top_column)+              ((inner_horizontal_blocked .|. bit (inner_end - inner_top_column)) `unsafeShiftR` (inner_top_column+1))+        let top_column = inner_top_column + 1+            top_column_bit = bit top_column+            bottom_column = inner_end - (inner_top_column + inner_reflected_bottom_column_offset + 1) + 1+            bottom_column_bit = bit bottom_column+        search+            (updateValue+                [(window_end,window_start+bottom_column)+                ,(window_start,window_start+top_column)+                ]+                value+           )+           (window_size-2)+           (NQueensSearchState+                (number_of_queens_remaining-2)+                (window_start+1)+                (occupied_rows `unsafeShiftR` 1)+               ((occupied_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. top_column_bit .|. (bottom_column_bit `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. top_column_bit .|. (bottom_column_bit `rotateR` end))+           )++    -- break the symmetry by placing queens only on the vertical sides+    breakAtVerticalSides = do+        PositionAndBit inner_right_row _ ←+            getOpenings+               (inner_size-1)+                inner_vertical_blocked+        PositionAndBit inner_reflected_left_row_offset _ ←+            getOpenings+               (inner_end-inner_right_row)+              ((inner_vertical_blocked .|. bit (inner_end - inner_right_row)) `unsafeShiftR` (inner_right_row+1))+        let right_row = inner_right_row + 1+            right_row_bit = bit right_row+            reflected_right_row_bit = bit (end-right_row)+            left_row = inner_end - (inner_right_row + inner_reflected_left_row_offset + 1) + 1+            left_row_bit = bit left_row+            reflected_left_row_bit = bit (end-left_row)+        search+            (updateValue+                [(window_start+left_row,window_end)+                ,(window_start+right_row,window_start)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-2)+                (window_start+1)+               ((occupied_rows .|. right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+                (occupied_columns `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. right_row_bit .|. (left_row_bit `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. reflected_left_row_bit .|. (reflected_right_row_bit `rotateR` end))+            )++    -- break by placing a queen at the bottom-left corner+    breakAtBottomLeftCorner = do+        PositionAndBit inner_right_row inner_right_row_bit ←+            getOpenings inner_size inner_vertical_blocked+        PositionAndBit inner_top_column _ ←+            getOpenings inner_size (inner_horizontal_blocked .|. inner_right_row_bit)+        let right_row = inner_right_row+1+            top_column = inner_top_column+1                +            right_row_bit = bit right_row+            reflected_right_row_bit = bit (end-right_row)+            top_column_bit = bit top_column+        search+            (updateValue+                [(window_start,window_start+top_column)+                ,(window_start+right_row,window_start)+                ,(window_end,window_end)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-3)+                (window_start+1)+                ((occupied_rows .|. right_row_bit) `unsafeShiftR` 1)+                ((occupied_columns .|. top_column_bit) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. right_row_bit .|. top_column_bit) `unsafeShiftR` 2)+                 (occupied_positive_diagonals .|. 1 .|. top_column_bit .|. (reflected_right_row_bit `rotateR` end))+            )++    -- break by placing a queen at the top-left corner+    breakAtTopLeftCorner = do+        PositionAndBit inner_right_row inner_right_row_bit ←+            getOpenings inner_size inner_vertical_blocked+        PositionAndBit inner_reflected_bottom_column _ ←+            getOpenings inner_size (inner_horizontal_blocked .|. inner_right_row_bit)+        let right_row = inner_right_row + 1+            bottom_column = inner_end - inner_reflected_bottom_column + 1                +            right_row_bit = bit right_row+            reflected_right_row_bit = bit (end-right_row)+            bottom_column_bit = bit bottom_column+        search+            (updateValue+                [(window_end,window_start+bottom_column)+                ,(window_start+right_row,window_start)+                ,(window_start,window_end)+                ]+                value+            )+            (window_size-2)+            (NQueensSearchState+                (number_of_queens_remaining-3)+                (window_start+1)+                ((occupied_rows .|. right_row_bit) `unsafeShiftR` 1)+                ((occupied_columns .|. bottom_column_bit) `unsafeShiftR` 1)+                ((occupied_negative_diagonals .|. end_bit .|. right_row_bit .|. (bottom_column_bit `unsafeShiftL` end)) `unsafeShiftR` 2)+                 (occupied_positive_diagonals .|. ((reflected_right_row_bit .|. bottom_column_bit) `rotateR` end))+            )++    -- preserve the 180-degree rotational symmetry+    preserve180 = do+        PositionAndBit inner_top_column inner_top_column_bit ←+            getOpenings+                inner_size+                inner_horizontal_blocked_excluding_middle+        let top_column = inner_top_column + 1+            top_column_bit = bit top_column+            bottom_column = inner_end - inner_top_column + 1+            bottom_column_bit = bit bottom_column+        PositionAndBit inner_right_row _ ←+            getOpenings+                inner_size+               (inner_vertical_blocked_excluding_middle .|. inner_top_column_bit)+        let right_row = inner_right_row + 1+            right_row_bit = bit right_row+            left_row = inner_end - inner_right_row + 1+            left_row_bit = bit left_row+        break180+            (updateValue+                [(window_start+left_row,window_end)+                ,(window_start+right_row,window_start)+                ,(window_end,window_start+bottom_column)+                ,(window_start,window_start+top_column)+                ]+                value+            )+            (NQueensBreak180State+                (number_of_queens_remaining-4)+                (window_start+1)+                (window_size-2)+               ((occupied_rows .|. right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+               ((occupied_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. top_column_bit .|. right_row_bit .|. ((bottom_column_bit .|. left_row_bit) `rotateR` end))+                (occupied_right_positive_diagonals .|. top_column_bit .|. right_row_bit)+            )++    -- preserve the 180-degree symmetry for the horizontal sides+    preserve180Horizontal = do+        PositionAndBit inner_top_column _ ←+            getOpenings+                inner_size+                inner_horizontal_blocked_excluding_middle+        let top_column = inner_top_column + 1+            top_column_bit = bit top_column+            bottom_column = inner_end - inner_top_column + 1+            bottom_column_bit = bit bottom_column+        break180+            (updateValue+                [(window_end,window_start+bottom_column)+                ,(window_start,window_start+top_column)+                ]+                value+           )+           (NQueensBreak180State+                (number_of_queens_remaining-2)+                (window_start+1)+                (window_size-2)+                (occupied_rows `unsafeShiftR` 1)+               ((occupied_columns .|. top_column_bit .|. bottom_column_bit) `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. top_column_bit .|. (bottom_column_bit `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. top_column_bit .|. (bottom_column_bit `rotateR` end))+                (occupied_right_positive_diagonals .|. top_column_bit)+           )++    -- preserve the 180-degree symmetry for the vertical sides+    preserve180Vertical = do+        PositionAndBit inner_right_row _ ←+            getOpenings+                inner_size+                inner_vertical_blocked_excluding_middle+        let right_row = inner_right_row + 1+            right_row_bit = bit right_row+            left_row = inner_end - inner_right_row + 1+            left_row_bit = bit left_row+        break180+            (updateValue+                [(window_start+left_row,window_end)+                ,(window_start+right_row,window_start)+                ]+                value+            )+            (NQueensBreak180State+                (number_of_queens_remaining-2)+                (window_start+1)+                (window_size-2)+               ((occupied_rows .|. right_row_bit .|. left_row_bit) `unsafeShiftR` 1)+                (occupied_columns `unsafeShiftR` 1)+               ((occupied_negative_diagonals .|. right_row_bit .|. (left_row_bit `unsafeShiftL` end)) `unsafeShiftR` 2)+                (occupied_positive_diagonals .|. right_row_bit .|. (left_row_bit `rotateR` end))+                (occupied_right_positive_diagonals .|. right_row_bit)+            )++    -- all sides are occupied, so go to the next layer in+    nextWindow = break180 value $+        NQueensBreak180State+             number_of_queens_remaining+            (window_start+1)+            (window_size-2)+            (occupied_rows `unsafeShiftR` 1)+            (occupied_columns `unsafeShiftR` 1)+            (occupied_negative_diagonals `unsafeShiftR` 2)+             occupied_positive_diagonals+             occupied_right_positive_diagonals++--------------------------------------------------------------------------------+---------------------------- Brute-force searching -----------------------------+--------------------------------------------------------------------------------++{- $brute-force+After the symmetry has been fully broken, the brute-force approach attempts to+place queens in the remaining inner sub-board.  When the number of queens falls+to 10 or less, it farms the rest of the search out to a routine written in C.+ -}++{-| The state during the brute-force search. -}+data NQueensSearchState = NQueensSearchState+    {   s_number_of_queens_remaining :: {-# UNPACK #-} !Word+    ,   s_row :: {-# UNPACK #-} !Int+    ,   s_occupied_rows :: {-# UNPACK #-} !Word64+    ,   s_occupied_columns :: {-# UNPACK #-} !Word64+    ,   s_occupied_negative_diagonals :: {-# UNPACK #-} !Word64+    ,   s_occupied_positive_diagonals :: {-# UNPACK #-} !Word64+    }++{-| Using brute-force to find placements for all of the remaining queens. -}+nqueensSearch ::+    (MonadPlus m+    ,Typeable α+    ,Typeable β+    ) ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    α {-^ partial solution -} →+    Int {-^ board size -} →+    NQueensSearchState {-^ current state -} →+    m β {-^ the final result -}+nqueensSearch updateValue_ finalizeValue initial_value size initial_search_state@(NQueensSearchState _ window_start _ _ _ _) =+    go initial_value initial_search_state+  where+    updateValue = updateValue_ . convertSolutionToWord+    go !value !s@(NQueensSearchState+                    number_of_queens_remaining+                    row+                    occupied_rows+                    occupied_columns+                    occupied_negative_diagonals+                    occupied_positive_diagonals+               )+      | number_of_queens_remaining <= 10 =+         nqueensCSearch+            updateValue_+            finalizeValue+            value+            size+            window_start+            s+      | occupied_rows .&. 1 == 0 =+         (getOpenings size $+            occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals+         )+         >>=+         \(PositionAndBit offset offset_bit) → go+            ([(row,window_start+offset)] `updateValue` value)+            (NQueensSearchState+                (number_of_queens_remaining-1)+                (row+1)+                (occupied_rows `unsafeShiftR` 1)+                (occupied_columns .|. offset_bit)+                ((occupied_negative_diagonals .|. offset_bit) `unsafeShiftR` 1)+                ((occupied_positive_diagonals .|. offset_bit) `rotateL` 1)+            )+      | otherwise =+         go value+            (NQueensSearchState+                 number_of_queens_remaining+                (row+1)+                (occupied_rows `unsafeShiftR` 1)+                 occupied_columns+                (occupied_negative_diagonals `unsafeShiftR` 1)+                (occupied_positive_diagonals `rotateL` 1)+            )+{-# INLINE nqueensSearch #-}++{-| Interface for directly using the brute-force search approach -} +nqueensBruteForceGeneric ::+    (MonadPlus m+    ,Typeable α+    ,Typeable β+    ) ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    α {-^ initial solution -} →+    Word {-^ board size -} →+    m β {-^ the final result -}+nqueensBruteForceGeneric updateValue finalizeValue initial_value 1 = finalizeValue . updateValue [(0,0)] $ initial_value+nqueensBruteForceGeneric _ _ _ 2 = mzero+nqueensBruteForceGeneric _ _ _ 3 = mzero+nqueensBruteForceGeneric updateValue finalizeValue initial_value n = nqueensSearch updateValue finalizeValue initial_value (fromIntegral n) $ NQueensSearchState n 0 0 0 0 0+{-# INLINE nqueensBruteForceGeneric #-}++{-| Generates the solutions to the n-queens problem with the given board size. -}+nqueensBruteForceSolutions :: MonadPlus m ⇒ Word → m NQueensSolution+nqueensBruteForceSolutions = nqueensBruteForceGeneric (++) return []+{-# SPECIALIZE nqueensBruteForceSolutions :: Word → NQueensSolutions #-}+{-# SPECIALIZE nqueensBruteForceSolutions :: Word → Tree NQueensSolution #-}++{-| Generates the solution count to the n-queens problem with the given board size. -}+nqueensBruteForceCount :: MonadPlus m ⇒ Word → m WordSum+nqueensBruteForceCount = nqueensBruteForceGeneric (const id) (const . return $ WordSum 1) ()+{-# SPECIALIZE nqueensBruteForceCount :: Word → [WordSum] #-}+{-# SPECIALIZE nqueensBruteForceCount :: Word → Tree WordSum #-}++--------------------------------------------------------------------------------+--------------------------------- C inner-loop ---------------------------------+--------------------------------------------------------------------------------++{-| C code that performs a brute-force search for the remaining queens.  The+    last three arguments are allowed to be NULL, in which case they are ignored+    and only the count is returned.+ -}+foreign import ccall safe "queens.h LogicGrowsOnTrees_Queens_count_solutions" c_LogicGrowsOnTrees_Queens_count_solutions ::+    CUInt {-^ board size -} →+    CUInt {-^ number of queens remaining -} →+    CUInt {-^ row number -} →+    Word64 {-^ occupied rows -} →+    Word64 {-^ occupied columns -} →+    Word64 {-^ occupied negative diagonals -} →+    Word64 {-^ occupied positive diagonals -} →+    FunPtr (CUInt -> CUInt → IO ()) {-^ function to push a coordinate on the partial solution;  may be NULL ^-} →+    FunPtr (IO ()) {-^ function to pop a coordinate from partial solution;  may be NULL ^-}  →+    FunPtr (IO ()) {-^ function to finalize a solution;  may be NULL ^-}  →+    IO CUInt++{-| wrapper stub for the push value function pointer -}+foreign import ccall "wrapper" mkPushValue :: (CUInt → CUInt → IO ()) → IO (FunPtr (CUInt → CUInt → IO ()))++{-| wrapper stub for the pop value function pointer -}+foreign import ccall "wrapper" mkPopValue :: IO () → IO (FunPtr (IO ()))++{-| wrapper stub for the finalize value function pointer -}+foreign import ccall "wrapper" mkFinalizeValue :: IO () → IO (FunPtr (IO ()))++{-| Calls C code to perform a brute-force search for the remaining queens.  The+    types α and β must be   'Typeable' because this function actually optimizes+    for the case where only counting is being done by providing null values for+    the function pointer inputs.+ -}+nqueensCSearch ::+    ∀ α m β.+    (MonadPlus m+    ,Typeable α+    ,Typeable β+    ) ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    α {-^ partial solution -} →+    Int {-^ board size -} →+    Int {-^ window start -} →+    NQueensSearchState {-^ current state -} →+    m β {-^ the final result -}+nqueensCSearch _ finalizeValue value _ _ NQueensSearchState{s_number_of_queens_remaining=0} = finalizeValue value+nqueensCSearch updateValue finalizeValue value size window_start NQueensSearchState{..}+  | typeOf value == typeOf () && typeOf (undefined :: β) == typeOf (undefined :: WordSum) = do+        Just (WordSum multiplier) ← liftM cast (finalizeValue value)+        let number_found =+                fromIntegral+                .+                unsafePerformIO+                $+                c_LogicGrowsOnTrees_Queens_count_solutions+                    (fromIntegral size)+                    (fromIntegral s_number_of_queens_remaining)+                    (fromIntegral s_row)+                    s_occupied_rows+                    s_occupied_columns+                    s_occupied_negative_diagonals+                    s_occupied_positive_diagonals+                    nullFunPtr+                    nullFunPtr+                    nullFunPtr+        return . fromJust . cast $ WordSum (multiplier * number_found)+  | otherwise = unsafePerformIO $ do+        value_stack_ref ← newIORef [value]+        finalized_values ← newIORef mzero+        push_value_funptr ← mkPushValue $ \row offset → modifyIORef value_stack_ref (\stack@(value:_) → updateValue [(fromIntegral row, fromIntegral window_start + fromIntegral offset)] value:stack)+        pop_value_funptr ← mkPopValue $ modifyIORef value_stack_ref tail+        finalize_value_funptr ← mkFinalizeValue $ do+            value ← head <$> readIORef value_stack_ref+            let finalized_value = finalizeValue value+            old_value ← readIORef finalized_values+            new_value ← evaluate $ old_value `mplus` finalized_value+            writeIORef finalized_values new_value+        _ ← c_LogicGrowsOnTrees_Queens_count_solutions+                (fromIntegral size)+                (fromIntegral s_number_of_queens_remaining)+                (fromIntegral s_row)+                s_occupied_rows+                s_occupied_columns+                s_occupied_negative_diagonals+                s_occupied_positive_diagonals+                push_value_funptr+                pop_value_funptr+                finalize_value_funptr+        freeHaskellFunPtr push_value_funptr+        freeHaskellFunPtr pop_value_funptr+        freeHaskellFunPtr finalize_value_funptr+        readIORef finalized_values++{-| Interface for directly using the C search approach -} +nqueensCGeneric ::+    (MonadPlus m+    ,Typeable α+    ,Typeable β+    ) ⇒+    ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} →+    (α → m β) {-^ function that finalizes the partial solution -} →+    α {-^ initial value -} →+    Word {-^ the board size -} →+    m β {-^ the final result -}+nqueensCGeneric updateValue finalizeValue initial_value 1 =+    finalizeValue . updateValue [(0,0)] $ initial_value+nqueensCGeneric _ _ _ 2 = mzero+nqueensCGeneric _ _ _ 3 = mzero+nqueensCGeneric updateValue finalizeValue initial_value n =+    nqueensCSearch updateValue finalizeValue initial_value (fromIntegral n) 0 $+        NQueensSearchState n 0 0 0 0 0+{-# INLINE nqueensCGeneric #-}++{-| Generates the solutions to the n-queens problem with the given board size. -}+nqueensCSolutions :: MonadPlus m ⇒ Word → m NQueensSolution+nqueensCSolutions = nqueensCGeneric (++) return []+{-# SPECIALIZE nqueensCSolutions :: Word → NQueensSolutions #-}+{-# SPECIALIZE nqueensCSolutions :: Word → Tree NQueensSolution #-}++{-| Generates the solution count to the n-queens problem with the given board size. -}+nqueensCCount :: MonadPlus m ⇒ Word → m WordSum+nqueensCCount = nqueensCGeneric (const id) (const . return $ WordSum 1) ()+{-# SPECIALIZE nqueensCCount :: Word → [WordSum] #-}+{-# SPECIALIZE nqueensCCount :: Word → Tree WordSum #-}++--------------------------------------------------------------------------------+------------------------------ Utility functions -------------------------------+--------------------------------------------------------------------------------++{-| Computes all rotations and reflections of the given solution. -}+allRotationsAndReflectionsOf ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolutions {-^ all rotations and reflections of the given solution -}+allRotationsAndReflectionsOf = flip multiplySolution NoSymmetries++{-| Computes all rotations of the given solution. -}+allRotationsOf ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolutions {-^ all rotations of the given solution -}+allRotationsOf n = take 4 . iterate (rotateLeft n)++{-| Converts coordinates of type 'Int' to type 'Word'. -}+convertSolutionToWord :: [(Int,Int)] → [(Word,Word)]+convertSolutionToWord = map (fromIntegral *** fromIntegral)++{-| Extracts the outermost layers of a solution. -}+extractExteriorFromSolution ::+    Word {-^ board size -} →+    Word {-^ number of outer layers to extract -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolution {-^ the outermost layers of the solution -}+extractExteriorFromSolution size layers = filter . uncurry $ ((||) `on` (liftA2 (||) (< threshold_1) (> threshold_2)))+  where+    threshold_1 = layers+    threshold_2 = size-layers-1++{-| Get the openings for a queen -}+getOpenings ::+    MonadPlus m ⇒+    Int {-^ board size -} →+    Word64 {-^ occupied positions -} →+    m PositionAndBit {-^ open positions and their corresponding bits -}+getOpenings size blocked+    | blocked .&. mask == mask = mzero+    | otherwise = go (PositionAndBit 0 1)+  where+    mask = bit size - 1+    go !x@(PositionAndBit i b)+     | i >= size          = mzero+     | b .&. blocked == 0 = return x `mplus` go next_x+     | otherwise          = go next_x+     where+       next_x = PositionAndBit (i+1) (b `unsafeShiftL` 1)+{-# INLINE getOpenings #-}++{-| Get the symmetric openings for a queen -}+getSymmetricOpenings ::+    MonadPlus m ⇒+    Int {-^ board size -} →+    Word64 {-^ occupied positions -} →+    m PositionAndBitWithReflection {-^ open positions and their corresponding bits and reflections -}+getSymmetricOpenings size blocked+    | blocked .&. mask == mask = mzero+    | otherwise = go (PositionAndBitWithReflection 0 1 end end_bit)+  where+    end = size-1+    end_bit = bit end+    mask = bit size - 1+    go x@(PositionAndBitWithReflection i b ri rb)+     | i >= ri            = mzero+     | b .&. blocked == 0 = return x `mplus` return (PositionAndBitWithReflection ri rb i b) `mplus` go next_bit+     | otherwise          = go next_bit+     where+       next_bit = PositionAndBitWithReflection (i+1) (b `unsafeShiftL` 1) (ri-1) (rb `unsafeShiftR` 1)+{-# INLINE getSymmetricOpenings #-}++{-| Checks if a solution has reflection symmetry. -}+hasReflectionSymmetry ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    Bool {-^ true if the given solution has reflection symmetry -}+hasReflectionSymmetry n = liftA2 ((==) `on` sort) id (reflectSolution n)++{-| Checks if a solution has 90-degree rotation symmetry. -}+hasRotate90Symmetry ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    Bool {-^ true if the given solution has 90-degree rotation symmetry -}+hasRotate90Symmetry n = liftA2 ((==) `on` sort) id (rotateLeft n)++{-| Checks if a solution has 180-degree rotation symmetry. -}+hasRotate180Symmetry ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    Bool {-^ true if the given solution has 180-degree rotation symmetry -}+hasRotate180Symmetry n = liftA2 ((==) `on` sort) id (rotate180 n)++{-| Returns the number of equivalent solutions for a solution with a given symmetry. -}+multiplicityForSymmetry :: NQueensSymmetry → Word+multiplicityForSymmetry AllSymmetries = 1+multiplicityForSymmetry AllRotations = 2+multiplicityForSymmetry Rotate180Only = 4+multiplicityForSymmetry NoSymmetries = 8+{-# INLINE multiplicityForSymmetry #-}++{-| Gets all of the equivalent solutions with an equivalent symmetry. -}+multiplySolution :: MonadPlus m ⇒+    Word {-^ board size -} →+    NQueensSymmetry {-^ the symmetry of the solution -} →+    NQueensSolution {-^ a solution with the given symmetry -} →+    m NQueensSolution {-^ the equivalent solutions of the given solution -}+multiplySolution n = go+  where+    go AllSymmetries = return+    go AllRotations = liftM2 (mplus `on` return) id (reflectSolution n) >=> go AllSymmetries+    go Rotate180Only = liftM2 (mplus `on` return) id (rotateLeft n) >=> go AllRotations+    go NoSymmetries = liftM2 (mplus `on` return) id (rotate180 n) >=> go Rotate180Only+{-# INLINE multiplySolution #-}++{-| Reflects the bits in a number so that each bit at position i is moved to+    position -i (i.e., what you get when you take a bit at position 0 and rotate+    it i positions to the right)+ -}+reflectBits :: Word64 → Word64+reflectBits = go 0 (0::Int) 1+  where+    go !accum 64 _ _ = accum+    go !accum !column !column_bit !bits =+        go (accum + column_bit * (bits .&. 1))+           (column + 1)+           (column_bit `unsafeShiftL` 1)+           (bits `rotateL` 1)++{-| Reflects the columns of a solution -}+reflectSolution ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolution {-^ the solution with its columns reflected -}+reflectSolution n old_solution = map (\(row,col) → (row,last-col)) old_solution+  where+    last = n - 1++{-| Rotate a solution left by 180 degrees. -}+rotate180 ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolution {-^ the given solution rotated by 180 degrees -}+rotate180 n = map (\(row,col) → (last-row,last-col))+  where+    last = n - 1++{-| Rotate a solution left by 90 degrees. -}+rotateLeft ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolution {-^ the given solution rotated left by 90 degrees -}+rotateLeft n = map (\(row,col) → (col,last-row))+  where+    last = n - 1++{-| Rotate a solution right by 90 degrees. -}+rotateRight ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSolution {-^ the given solution rotated right by 90 degrees -}+rotateRight n = map (\(row,col) → (last-col,row))+  where+    last = n - 1++{-| Computes the symmetry class of the given solution -}+symmetryOf ::+    Word {-^ board size -} →+    NQueensSolution {-^ given solution -} →+    NQueensSymmetry {-^ the symmetry of the given solution -}+symmetryOf n solution+  | hasReflectionSymmetry n solution = AllSymmetries+  | hasRotate90Symmetry n solution = AllRotations+  | hasRotate180Symmetry n solution = Rotate180Only+  | otherwise = NoSymmetries++
+ sources/LogicGrowsOnTrees/Location.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains infrastructure for working with 'Location's, which+    indicate a location within a tree but, unlike 'Path', without the cached+    values.+ -}+module LogicGrowsOnTrees.Location+    (+    -- * Type-classes+      MonadLocatable(..)+    -- * Types+    , Location+    , Solution(..)+    , LocatableT(..)+    , LocatableTree+    , LocatableTreeIO+    , LocatableTreeT(..)+    -- * Utility functions+    , applyCheckpointCursorToLocation+    , applyContextToLocation+    , applyPathToLocation+    , branchingFromLocation+    , labelFromBranching+    , labelFromContext+    , labelFromPath+    , leftBranchOf+    , locationTransformerForBranchChoice+    , normalizeLocatableTree+    , normalizeLocatableTreeT+    , rightBranchOf+    , rootLocation+    , runLocatableT+    , sendTreeDownLocation+    , sendTreeTDownLocation+    , solutionsToMap+    -- * Exploration functions+    , exploreLocatableTree+    , exploreLocatableTreeT+    , exploreLocatableTreeTAndIgnoreResults+    , exploreTreeWithLocations+    , exploreTreeTWithLocations+    , exploreTreeWithLocationsStartingAt+    , exploreTreeTWithLocationsStartingAt+    , exploreLocatableTreeUntilFirst+    , exploreLocatableTreeUntilFirstT+    , exploreTreeUntilFirstWithLocation+    , exploreTreeTUntilFirstWithLocation+    , exploreTreeUntilFirstWithLocationStartingAt+    , exploreTreeTUntilFirstWithLocationStartingAt+    ) where+++import Control.Applicative (Alternative(..),Applicative(..))+import Control.Exception (throw)+import Control.Monad (MonadPlus(..),(>=>),liftM,liftM2)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Operational (ProgramViewT(..),viewT)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..),ask)++import Data.Composition+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromJust)+import Data.Monoid+import Data.Foldable as Fold+import Data.Function (on)+import Data.Functor.Identity (Identity,runIdentity)+import Data.Sequence (viewl,ViewL(..))+import Data.SequentialIndex (SequentialIndex,root,leftChild,rightChild)++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Path++--------------------------------------------------------------------------------+--------------------------------- Type-classes ---------------------------------+--------------------------------------------------------------------------------++{-| The class 'MonadLocatable' allows you to get your current location within a tree. -}+class MonadPlus m ⇒ MonadLocatable m where+    getLocation :: m Location++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++{-| A 'Location' identifies a location in a tree;  unlike 'Path' it only+    contains information about the list of branches that have been taken, and+    not information about the cached values encounted along the way.+ -}+newtype Location = Location { unwrapLocation :: SequentialIndex } deriving (Eq)++{-| A 'Solution' is a result tagged with the location of the leaf at which it+    was found.+ -}+data Solution α = Solution+    {   solutionLocation :: Location+    ,   solutionResult :: α+    } deriving (Eq,Ord,Show)++{-| The 'Monoid' instance constructs a location that is the result of appending+    the path in the second argument to the path in the first argument.+ -}+instance Monoid Location where+    mempty = rootLocation+    xl@(Location x) `mappend` yl@(Location y)+      | x == root = yl+      | y == root = xl+      | otherwise = Location $ go y root x+      where+        go original_label current_label product_label =+            case current_label `compare` original_label of+                EQ → product_label+            -- Note:  the following is counter-intuitive, but it makes sense if you think of it as+            --        being where you need to go to get to the original label instead of where you+            --        currently are with respect to the original label+                GT → (go original_label `on` (fromJust . leftChild)) current_label product_label+                LT → (go original_label `on` (fromJust . rightChild)) current_label product_label++{-| The 'Ord' instance performs the comparison using the list of branches in the+    path defined by the location, which is obtained using the function+    'branchingFromLocation'.+ -}+instance Ord Location where+    compare = compare `on` branchingFromLocation++instance Show Location where+    show = fmap (\branch → case branch of {LeftBranch → 'L'; RightBranch → 'R'}) . branchingFromLocation++{-| 'LocatableT' is a monad transformer that allows you to take any MonadPlus+    and add to it the ability to tell where you are in the tree created by the+    'mplus's.+ -}+newtype LocatableT m α = LocatableT { unwrapLocatableT :: ReaderT Location m α }+    deriving (Applicative,Functor,Monad,MonadIO,MonadTrans)++instance (Alternative m, Monad m) ⇒ Alternative (LocatableT m) where+    empty = LocatableT $ lift empty+    LocatableT left <|> LocatableT right = LocatableT . ReaderT $+        \branch → (runReaderT left (leftBranchOf branch)) <|> (runReaderT right (rightBranchOf branch))++instance MonadPlus m ⇒ MonadLocatable (LocatableT m) where+    getLocation = LocatableT $ ask++instance MonadPlus m ⇒ MonadPlus (LocatableT m) where+    mzero = LocatableT $ lift mzero+    LocatableT left `mplus` LocatableT right = LocatableT . ReaderT $+        \branch → (runReaderT left (leftBranchOf branch)) `mplus` (runReaderT right (rightBranchOf branch))++instance MonadExplorableTrans m ⇒ MonadExplorableTrans (LocatableT m) where+    type NestedMonad (LocatableT m) = NestedMonad m+    runAndCache = LocatableT . lift . runAndCache+    runAndCacheGuard = LocatableT . lift . runAndCacheGuard+    runAndCacheMaybe = LocatableT . lift . runAndCacheMaybe++instance MonadPlus m ⇒ Monoid (LocatableT m α) where+    mempty = mzero+    mappend = mplus++{-| A 'Tree' augmented with the ability to get the current location -}+type LocatableTree = LocatableTreeT Identity++{-| Like 'LocatableTree', but running in the IO monad. -}+type LocatableTreeIO = LocatableTreeT IO++{-| Like 'LocatableTree', but running in an arbitrary monad. -}+newtype LocatableTreeT m α = LocatableTreeT { unwrapLocatableTreeT :: LocatableT (TreeT m) α }+    deriving (Alternative,Applicative,Functor,Monad,MonadIO,MonadLocatable,MonadPlus,Monoid)++instance MonadTrans LocatableTreeT where+    lift = LocatableTreeT . lift . lift++instance Monad m ⇒ MonadExplorableTrans (LocatableTreeT m) where+    type NestedMonad (LocatableTreeT m) = m+    runAndCache = LocatableTreeT . runAndCache+    runAndCacheGuard = LocatableTreeT . runAndCacheGuard+    runAndCacheMaybe = LocatableTreeT . runAndCacheMaybe++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++------------------------------ Utility functions -------------------------------++{-| Append the path indicated by a checkpoint cursor to the given location's path. -}+applyCheckpointCursorToLocation ::+    CheckpointCursor {-^ a path within the subtree -} →+    Location {-^ the location of the subtree -} →+    Location {-^ the location within the full tree obtained by following the path+                 to the subtree and then the path indicated by the checkpoint+                 cursor+              -}+applyCheckpointCursorToLocation cursor =+    case viewl cursor of+        EmptyL → id+        step :< rest →+            applyCheckpointCursorToLocation rest+            .+            case step of+                CachePointD _ → id+                ChoicePointD active_branch _ → locationTransformerForBranchChoice active_branch++{-| Append the path indicated by a context to the given location's path. -}+applyContextToLocation ::+    Context m α {-^ the path within the subtree -} →+    Location {-^ the location of the subtree -} →+    Location {-^ the location within the full tree obtained by following the path+                 to the subtree and then the path indicated by the context+              -}+applyContextToLocation context =+    case viewl context of+        EmptyL → id+        step :< rest →+            applyContextToLocation rest+            .+            case step of+                CacheContextStep _ → id+                LeftBranchContextStep _ _ → leftBranchOf+                RightBranchContextStep → rightBranchOf++{-| Append a path to a location's path. -}+applyPathToLocation ::+    Path {-^ a path within the subtree -} →+    Location {-^ the location of the subtree -} →+    Location {-^ the location within the full tree obtained by following the path+                 to the subtree and then the given path+              -}+applyPathToLocation path =+    case viewl path of+        EmptyL → id+        step :< rest →+            applyPathToLocation rest+            .+            case step of+                ChoiceStep active_branch → locationTransformerForBranchChoice active_branch+                CacheStep _ → id++{-| Converts a location to a list of branch choices. -}+branchingFromLocation :: Location → [BranchChoice]+branchingFromLocation = go root . unwrapLocation+  where+    go current_label original_label =+        case current_label `compare` original_label of+            EQ → []+            GT → LeftBranch:go (fromJust . leftChild $ current_label) original_label+            LT → RightBranch:go (fromJust . rightChild $ current_label) original_label++{-| Converts a list (or other 'Foldable') of branch choices to a location. -}+labelFromBranching :: Foldable t ⇒ t BranchChoice → Location+labelFromBranching = Fold.foldl' (flip locationTransformerForBranchChoice) rootLocation++{-| Contructs a 'Location' representing the location within the tree indicated by the 'Context'. -}+labelFromContext :: Context m α → Location+labelFromContext = flip applyContextToLocation rootLocation++{-| Contructs a 'Location' representing the location within the tree indicated by the 'Path'. -}+labelFromPath :: Path → Location+labelFromPath = flip applyPathToLocation rootLocation++{-| Returns the 'Location' at the left branch of the given location. -}+leftBranchOf :: Location → Location+leftBranchOf = Location . fromJust . leftChild . unwrapLocation++{-| Convenience function takes a branch choice and returns a location+    transformer that appends the branch choice to the given location.+ -}+locationTransformerForBranchChoice :: BranchChoice → (Location → Location)+locationTransformerForBranchChoice LeftBranch = leftBranchOf+locationTransformerForBranchChoice RightBranch = rightBranchOf++{-| Converts a 'LocatableTree' to a 'Tree'. -}+normalizeLocatableTree :: LocatableTree α → Tree α+normalizeLocatableTree = runLocatableT . unwrapLocatableTreeT++{-| Converts a 'LocatableTreeT' to a 'TreeT'. -}+normalizeLocatableTreeT :: LocatableTreeT m α → TreeT m α+normalizeLocatableTreeT = runLocatableT . unwrapLocatableTreeT++{-| Returns the 'Location' at the right branch of the given location. -}+rightBranchOf :: Location → Location+rightBranchOf = Location . fromJust . rightChild . unwrapLocation++{-| The location at the root of the tree. -}+rootLocation :: Location+rootLocation = Location root++{-| Runs a 'LocatableT' to obtain the nested monad. -}+runLocatableT :: LocatableT m α → m α+runLocatableT = flip runReaderT rootLocation . unwrapLocatableT++{-| Walks down a 'Tree' to the subtree at the given 'Location'. This function is+    analogous to 'LogicGrowsOnTrees.Path.sendTreeDownPath', and shares the+    same caveats.+ -}+sendTreeDownLocation :: Location → Tree α → Tree α+sendTreeDownLocation label = runIdentity . sendTreeTDownLocation label++{-| Like 'sendTreeDownLocation', but for impure trees. -}+sendTreeTDownLocation :: Monad m ⇒ Location → TreeT m α → m (TreeT m α)+sendTreeTDownLocation (Location label) = go root+  where+    go parent tree+      | parent == label = return tree+      | otherwise =+          (viewT . unwrapTreeT) tree >>= \view → case view of+            Return _ → throw TreeEndedBeforeEndOfWalk+            Null :>>= _ → throw TreeEndedBeforeEndOfWalk+            ProcessPendingRequests :>>= k → go parent . TreeT . k $ ()+            Cache mx :>>= k → mx >>= maybe (throw TreeEndedBeforeEndOfWalk) (go parent . TreeT . k)+            Choice left right :>>= k →+                if parent > label+                then+                    go+                        (fromJust . leftChild $ parent)+                        (left >>= TreeT . k)+                else+                    go+                        (fromJust . rightChild $ parent)+                        (right >>= TreeT . k)++{-| Converts a list (or other 'Foldable') of solutions to a 'Map' from+    'Location's to results.+ -}+solutionsToMap :: Foldable t ⇒ t (Solution α) → Map Location α+solutionsToMap = Fold.foldl' (flip $ \(Solution label solution) → Map.insert label solution) Map.empty++------------------------------ Exploration functions -------------------------------++{-| Explore all the nodes in a 'LocatableTree' and sum over all the results in the+    leaves.+ -}+exploreLocatableTree :: Monoid α ⇒ LocatableTree α → α+exploreLocatableTree = exploreTree . runLocatableT . unwrapLocatableTreeT++{-| Same as 'exploreLocatableTree', but for an impure tree. -}+exploreLocatableTreeT :: (Monoid α,Monad m) ⇒ LocatableTreeT m α → m α+exploreLocatableTreeT = exploreTreeT . runLocatableT . unwrapLocatableTreeT++{-| Same as 'exploreLocatableTree', but the results are discarded so the tree is+    only explored for its side-effects.+ -}+exploreLocatableTreeTAndIgnoreResults :: Monad m ⇒ LocatableTreeT m α → m ()+exploreLocatableTreeTAndIgnoreResults = exploreTreeTAndIgnoreResults . runLocatableT . unwrapLocatableTreeT++{-| Explores all of the nodes of a tree, returning a list of solutions each+    tagged with the location at which it was found.+ -}+exploreTreeWithLocations :: Tree α → [Solution α]+exploreTreeWithLocations = runIdentity . exploreTreeTWithLocations++{-| Like 'exploreTreeWithLocations' but for an impure tree. -}+exploreTreeTWithLocations :: Monad m ⇒ TreeT m α → m [Solution α]+exploreTreeTWithLocations = exploreTreeTWithLocationsStartingAt rootLocation++{-| Like 'exploreTreeWithLocations', but for a subtree whose location is given by+    the first argument;  the solutions are labeled by the /absolute/ location+    within the full tree (as opposed to their relative location within the+    subtree).+ -}+exploreTreeWithLocationsStartingAt :: Location → Tree α → [Solution α]+exploreTreeWithLocationsStartingAt = runIdentity .* exploreTreeTWithLocationsStartingAt++{-| Like 'exploreTreeWithLocationsStartingAt' but for an impure trees. -}+exploreTreeTWithLocationsStartingAt :: Monad m ⇒ Location → TreeT m α → m [Solution α]+exploreTreeTWithLocationsStartingAt label =+    viewT . unwrapTreeT >=> \view →+    case view of+        Return x → return [Solution label x]+        Cache mx :>>= k → mx >>= maybe (return []) (exploreTreeTWithLocationsStartingAt label . TreeT . k)+        Choice left right :>>= k →+            liftM2 (++)+                (exploreTreeTWithLocationsStartingAt (leftBranchOf label) $ left >>= TreeT . k)+                (exploreTreeTWithLocationsStartingAt (rightBranchOf label) $ right >>= TreeT . k)+        Null :>>= _ → return []+        ProcessPendingRequests :>>= k → exploreTreeTWithLocationsStartingAt label . TreeT . k $ ()++{-| Explores all the nodes in a 'LocatableTree' until a result (i.e., a leaf) has+    been found; if a result has been found then it is returned wrapped in+    'Just', otherwise 'Nothing' is returned.+ -}+exploreLocatableTreeUntilFirst :: LocatableTree α → Maybe α+exploreLocatableTreeUntilFirst = exploreTreeUntilFirst . runLocatableT . unwrapLocatableTreeT++{-| Like 'exploreLocatableTreeUntilFirst' but for an impure tree. -}+exploreLocatableTreeUntilFirstT :: Monad m ⇒ LocatableTreeT m α → m (Maybe α)+exploreLocatableTreeUntilFirstT = exploreTreeTUntilFirst . runLocatableT . unwrapLocatableTreeT++{-| Explores all the nodes in a tree until a result (i.e., a leaf) has been found;+    if a result has been found then it is returned tagged with the location at+    which it was found and wrapped in 'Just', otherwise 'Nothing' is returned.+ -}+exploreTreeUntilFirstWithLocation :: Tree α → Maybe (Solution α)+exploreTreeUntilFirstWithLocation = runIdentity . exploreTreeTUntilFirstWithLocation++{-| Like 'exploreTreeUntilFirstWithLocation' but for an impure tree. -}+exploreTreeTUntilFirstWithLocation :: Monad m ⇒ TreeT m α → m (Maybe (Solution α))+exploreTreeTUntilFirstWithLocation = exploreTreeTUntilFirstWithLocationStartingAt rootLocation++{-| Like 'exploreTreeUntilFirstWithLocation', but for a subtree whose location is+    given by the first argument; the solution (if present) is labeled by the+    /absolute/ location within the full tree (as opposed to its relative+    location within the subtree).+ -}+exploreTreeUntilFirstWithLocationStartingAt :: Location → Tree α → Maybe (Solution α)+exploreTreeUntilFirstWithLocationStartingAt = runIdentity .* exploreTreeTUntilFirstWithLocationStartingAt++{-| Like 'exploreTreeUntilFirstWithLocationStartingAt' but for an impure tree. -}+exploreTreeTUntilFirstWithLocationStartingAt :: Monad m ⇒ Location → TreeT m α → m (Maybe (Solution α))+exploreTreeTUntilFirstWithLocationStartingAt = go .* exploreTreeTWithLocationsStartingAt+  where+    go = liftM $ \solutions →+        case solutions of+            [] → Nothing+            (x:_) → Just x
+ sources/LogicGrowsOnTrees/Parallel/Adapter/Threads.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This adapter implements parallelism by spawning multiple worker threads, the+    number of which can be changed arbitrarily during the run.++    NOTE: For the use of threads to results in parallelization, you need to make+    sure that the number of capabilities is at least as large as the largest+    number of worker threads you will be spawning. If you are using the+    'driver', then this will be taken care of for you. If not, then you will+    need to either call 'GHC.Conc.setNumCapabilities' (but only to increase the+    number of threads in GHC 7.4, and not too often as it may crash) or use the+    command-line argument @+RTS -N\#@, where @\#@ is the number of threads you+    want to run in parallel. The 'driver' takes care of this automatically by+    calling 'setNumCapabilities' a single time to set the number of capabilities+    equal to the number of request threads (provided via. a command-line+    argument).+ -}+module LogicGrowsOnTrees.Parallel.Adapter.Threads+    (+    -- * Driver+      driver+    -- * Controller+    , ThreadsControllerMonad+    , abort+    , changeNumberOfWorkersAsync+    , changeNumberOfWorkers+    , changeNumberOfWorkersToMatchCapabilities+    , fork+    , getCurrentProgressAsync+    , getCurrentProgress+    , getNumberOfWorkersAsync+    , getNumberOfWorkers+    , requestProgressUpdateAsync+    , requestProgressUpdate+    , setNumberOfWorkersAsync+    , setNumberOfWorkers+    , setWorkloadBufferSize+    -- * Outcome types+    , RunOutcome(..)+    , RunStatistics(..)+    , TerminationReason(..)+    -- * Exploration functions+    -- $exploration++    -- ** Sum over all results+    -- $all+    , exploreTree+    , exploreTreeStartingFrom+    , exploreTreeIO+    , exploreTreeIOStartingFrom+    , exploreTreeT+    , exploreTreeTStartingFrom+    -- ** Stop at first result+    -- $first+    , exploreTreeUntilFirst+    , exploreTreeUntilFirstStartingFrom+    , exploreTreeIOUntilFirst+    , exploreTreeIOUntilFirstStartingFrom+    , exploreTreeTUntilFirst+    , exploreTreeTUntilFirstStartingFrom+    -- ** Stop when sum of results meets condition+    -- *** Pull+    -- $pull+    , exploreTreeUntilFoundUsingPull+    , exploreTreeUntilFoundUsingPullStartingFrom+    , exploreTreeIOUntilFoundUsingPull+    , exploreTreeIOUntilFoundUsingPullStartingFrom+    , exploreTreeTUntilFoundUsingPull+    , exploreTreeTUntilFoundUsingPullStartingFrom+    -- *** Push+    -- $push+    , exploreTreeUntilFoundUsingPush+    , exploreTreeUntilFoundUsingPushStartingFrom+    , exploreTreeIOUntilFoundUsingPush+    , exploreTreeIOUntilFoundUsingPushStartingFrom+    , exploreTreeTUntilFoundUsingPush+    , exploreTreeTUntilFoundUsingPushStartingFrom+    -- * Generic explorer+    , runExplorer+    ) where++import Control.Applicative (Applicative,liftA3)+import Control.Concurrent (getNumCapabilities,killThread)+import Control.Monad (when)+import Control.Monad.CatchIO (MonadCatchIO)+import Control.Monad.IO.Class (MonadIO,liftIO)+import Control.Monad.Trans.State.Strict (get,modify)++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(mempty))+import Data.Void (absurd)++import GHC.Conc (setNumCapabilities)++import System.Console.CmdTheLine (OptInfo(..),required,opt,optInfo)+import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(DEBUG))+import System.Log.Logger.TH++import LogicGrowsOnTrees (Tree,TreeIO,TreeT)+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Parallel.Main+    (Driver(..)+    ,DriverParameters(..)+    ,RunOutcome(..)+    ,RunOutcomeFor+    ,RunStatistics(..)+    ,TerminationReason(..)+    ,mainParser+    )+import LogicGrowsOnTrees.Parallel.Common.RequestQueue+import LogicGrowsOnTrees.Parallel.Common.Worker+import LogicGrowsOnTrees.Parallel.Common.Workgroup hiding (C,unwrapC)+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Parallel.Purity++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [DEBUG]++--------------------------------------------------------------------------------+------------------------------------ Driver ------------------------------------+--------------------------------------------------------------------------------++{-| This is the driver for the threads adapter.  The number of workers is+    specified via. the (required) command-line option "-n"; 'setNumCapabilities'+    is called exactly once to make sure that there is an equal number of+    capabilities.+ -}+driver :: Driver IO shared_configuration supervisor_configuration m n exploration_mode+driver = Driver $ \DriverParameters{..} → do+    (shared_configuration,supervisor_configuration,number_of_threads) ←+        mainParser (liftA3 (,,) shared_configuration_term supervisor_configuration_term number_of_threads_term) program_info+    initializeGlobalState shared_configuration+    starting_progress ← getStartingProgress shared_configuration supervisor_configuration+    runExplorer+        (constructExplorationMode shared_configuration)+         purity+         starting_progress+        (do liftIO $ do+                number_of_capabilities ← getNumCapabilities+                when (number_of_capabilities < number_of_threads) $+                    setNumCapabilities number_of_threads+            setNumberOfWorkersAsync+                (fromIntegral number_of_threads)+                (return ())+            constructController shared_configuration supervisor_configuration+        )+        (constructTree shared_configuration)+     >>= notifyTerminated shared_configuration supervisor_configuration+  where+    number_of_threads_term = required (flip opt (+        (optInfo ["n","number-of-threads"])+        {   optName = "#"+        ,   optDoc = "This *required* option specifies the number of worker threads to spawn."+        }+        ) Nothing )++--------------------------------------------------------------------------------+---------------------------------- Controller ----------------------------------+--------------------------------------------------------------------------------++{-| This is the monad in which the thread controller will run. -}+newtype ThreadsControllerMonad exploration_mode α =+    C (WorkgroupControllerMonad (IntMap (WorkerEnvironment (ProgressFor exploration_mode))) exploration_mode α)+  deriving (Applicative,Functor,Monad,MonadCatchIO,MonadIO,RequestQueueMonad,WorkgroupRequestQueueMonad)++instance HasExplorationMode (ThreadsControllerMonad exploration_mode) where+    type ExplorationModeFor (ThreadsControllerMonad exploration_mode) = exploration_mode++{-| Changes the number of a parallel workers to equal the number of capabilities+    as reported by 'getNumCapabilities'.+ -}+changeNumberOfWorkersToMatchCapabilities :: ThreadsControllerMonad exploration_mode ()+changeNumberOfWorkersToMatchCapabilities =+    liftIO getNumCapabilities >>= flip setNumberOfWorkersAsync (return ()) . fromIntegral++--------------------------------------------------------------------------------+---------------------------- Exploration functions -----------------------------+--------------------------------------------------------------------------------++{- $exploration+The functions in this section are provided as a way to use the Threads adapter+directly rather than using the framework provided in+"LogicGrowsOnTrees.Parallel.Main". They are all specialized versions of+'runExplorer', which appears in the following section. The specialized versions+are provided for convenience --- specifically, to minimize the knowledge needed+of the implementation and how the types specialize for the various exploration+modes.++There are 3 × 2 × 4 = 24 functions in this section; the factor of 3 comes from+the fact that there are three cases of monad in which the exploration is run:+pure, IO, and impure (where IO is a special case of impure provided for+convenience); the factor of 2 comes from the fact that one can either start with+no progress or start with a given progress; and the factor of 4 comes from the+fact that there are four exploration modes: summing over all results, returning+the first result, summing over all results until a criteria is met with+intermediate results only being sent to the supervisor upon request, and the+previous mode but with all intermediate results being sent immediately to the+supervisor.+ -}++---------------------------- Sum over all results ------------------------------++{- $all+The functions in this section are for when you want to sum over all the results+in (the leaves of) the tree.+ -}++{-| Explore the pure tree and sum over all results. -}+exploreTree ::+    Monoid result ⇒+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) result) {-^ the outcome of the run -}+exploreTree = exploreTreeStartingFrom mempty++{-| Like 'exploreTree' but with a starting progress. -}+exploreTreeStartingFrom ::+    Monoid result ⇒+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) result) {-^ the outcome of the run -}+exploreTreeStartingFrom = runExplorer AllMode Pure++{-| Like 'exploreTree' but with the tree running in IO. -}+exploreTreeIO ::+    Monoid result ⇒+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) result) {-^ the outcome of the run -}+exploreTreeIO = exploreTreeIOStartingFrom mempty++{-| Like 'exploreTreeIO' but with a starting progress. -}+exploreTreeIOStartingFrom ::+    Monoid result ⇒+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) result) {-^ the outcome of the run -}+exploreTreeIOStartingFrom = runExplorer AllMode io_purity++{-| Like 'exploreTree' but with a generic impure tree. -}+exploreTreeT ::+    (Monoid result, MonadIO m) ⇒+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) result) {-^ the outcome of the run -}+exploreTreeT = flip exploreTreeTStartingFrom mempty++{-| Like 'exploreTreeT', but with a starting progress. -}+exploreTreeTStartingFrom ::+    (Monoid result, MonadIO m) ⇒+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (AllMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) result)+exploreTreeTStartingFrom = runExplorer AllMode  . ImpureAtopIO++---------------------------- Stop at first result ------------------------------++{- $first+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#first"+ -}++{-| Explore the pure tree until a result has been found. -}+exploreTreeUntilFirst ::+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFirst = exploreTreeUntilFirstStartingFrom mempty++{-| Like 'exploreTreeUntilFirst' but with a starting progress. -}+exploreTreeUntilFirstStartingFrom ::+    Checkpoint {-^ the starting progress -} →+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFirstStartingFrom = runExplorer FirstMode Pure++{-| Like 'exploreTreeUntilFirst' but with the tree running in IO. -}+exploreTreeIOUntilFirst ::+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFirst = exploreTreeIOUntilFirstStartingFrom mempty++{-| Like 'exploreTreeIOUntilFirst' but with a starting progress. -}+exploreTreeIOUntilFirstStartingFrom ::+    Checkpoint {-^ the starting progress -} →+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFirstStartingFrom = runExplorer FirstMode io_purity++{-| Like 'exploreTreeUntilFirst' but with a generic impure tree. -}+exploreTreeTUntilFirst ::+    MonadIO m ⇒+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFirst = flip exploreTreeTUntilFirstStartingFrom mempty++{-| Like 'exploreTreeTUntilFirst', but with a starting progress. -}+exploreTreeTUntilFirstStartingFrom ::+    MonadIO m ⇒+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    Checkpoint {-^ the starting progress -} →+    ThreadsControllerMonad (FirstMode result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome Checkpoint (Maybe (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFirstStartingFrom = runExplorer FirstMode . ImpureAtopIO++------------------------ Stop when sum of results found ------------------------++{- $pull+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#pull"++Note that because using these functions entails writing the controller yourself,+it is your responsibility to ensure that a global progress update is performed+on a regular basis in order to ensure that results are being gathered together+at the supervisor.+ -}++{-| Explore the pure tree until the sum of resuts meets a condition. -}+exploreTreeUntilFoundUsingPull ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFoundUsingPull = flip exploreTreeUntilFoundUsingPullStartingFrom mempty++{-| Like 'exploreTreeUntilFoundUsingPull' but with a starting progress. -}+exploreTreeUntilFoundUsingPullStartingFrom ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFoundUsingPullStartingFrom f = runExplorer (FoundModeUsingPull f) Pure++{-| Like 'exploreTreeUntilFoundUsingPull' but with the tree running in IO. -}+exploreTreeIOUntilFoundUsingPull ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFoundUsingPull = flip exploreTreeIOUntilFoundUsingPullStartingFrom mempty++{-| Like 'exploreTreeIOUntilFoundUsingPull' but with a starting progress. -}+exploreTreeIOUntilFoundUsingPullStartingFrom ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFoundUsingPullStartingFrom f = runExplorer (FoundModeUsingPull f) io_purity++{-| Like 'exploreTreeUntilFoundUsingPull' but with a generic impure tree. -}+exploreTreeTUntilFoundUsingPull ::+    (Monoid result, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFoundUsingPull f run = exploreTreeTUntilFoundUsingPullStartingFrom f run mempty++{-| Like 'exploreTreeTUntilFoundUsingPull' but with a starting progress. -}+exploreTreeTUntilFoundUsingPullStartingFrom ::+    (Monoid result, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPull result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFoundUsingPullStartingFrom f = runExplorer (FoundModeUsingPull f) . ImpureAtopIO++{- $push+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#push"+-}+++{-| Explore the pure tree until the sum of resuts meets a condition. -}+exploreTreeUntilFoundUsingPush ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFoundUsingPush = flip exploreTreeUntilFoundUsingPushStartingFrom mempty++{-| Like 'exploreTreeUntilFoundUsingPush', but with a starting result. -}+exploreTreeUntilFoundUsingPushStartingFrom ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    Tree result {-^ the (pure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeUntilFoundUsingPushStartingFrom f = runExplorer (FoundModeUsingPush f) Pure++{-| Like 'exploreTreeUntilFoundUsingPush' but with the tree running in IO. -}+exploreTreeIOUntilFoundUsingPush ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFoundUsingPush = flip exploreTreeIOUntilFoundUsingPushStartingFrom mempty++{-| Like 'exploreTreeIOUntilFoundUsingPush', but with a starting result. -}+exploreTreeIOUntilFoundUsingPushStartingFrom ::+    Monoid result ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeIO result {-^ the tree (which runs in the IO monad) -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeIOUntilFoundUsingPushStartingFrom f = runExplorer (FoundModeUsingPush f) io_purity++{-| Like 'exploreTreeUntilFoundUsingPush' but with a generic impure tree. -}+exploreTreeTUntilFoundUsingPush ::+    (Monoid result, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFoundUsingPush f run = exploreTreeTUntilFoundUsingPushStartingFrom f run mempty++{-| Like 'exploreTreeTUntilFoundUsingPush', but with a starting progress. -}+exploreTreeTUntilFoundUsingPushStartingFrom ::+    (Monoid result, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ α. m α → IO α) {-^ a function that runs the tree's monad in IO -} →+    Progress result {-^ the starting progress -} →+    ThreadsControllerMonad (FoundModeUsingPush result) () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m result {-^ the (impure) tree -} →+    IO (RunOutcome (Progress result) (Either result (Progress result))) {-^ the outcome of the run -}+exploreTreeTUntilFoundUsingPushStartingFrom f = runExplorer (FoundModeUsingPush f) . ImpureAtopIO++--------------------------------------------------------------------------------+-------------------------------- Generic runner --------------------------------+--------------------------------------------------------------------------------++{-| Explores the given tree using multiple threads to achieve parallelism.++    This function grants access to all of the functionality of this adapter,+    but because its generality complicates its use (primarily the fact that the+    types are dependent on the first parameter) you may find it easier to use+    one of the specialized functions in the preceding section.+ -}+runExplorer ::+    ExplorationMode exploration_mode {-^ the exploration mode -} →+    Purity m n {-^ the purity of the tree -} →+    (ProgressFor exploration_mode) {-^ the starting progress -} →+    ThreadsControllerMonad exploration_mode () {-^ the controller loop, which at the very least must start by increasing the number of workers from 0 to the desired number -} →+    TreeT m (ResultFor exploration_mode) {-^ the tree -} →+    IO (RunOutcomeFor exploration_mode) {-^ the outcome of the run -}+runExplorer exploration_mode purity starting_progress (C controller) tree =+    runWorkgroup+        exploration_mode+        mempty+        (\MessageForSupervisorReceivers{..} →+            let createWorker _ = return ()+                destroyWorker worker_id False = liftIO $ receiveQuitFromWorker worker_id+                destroyWorker worker_id True = do+                    get >>=+                        liftIO+                        .+                        sendAbortRequest+                        .+                        workerPendingRequests+                        .+                        fromJustOrBust ("destroyWorker: active record for worker " ++ show worker_id ++ " not found")+                        .+                        IntMap.lookup worker_id+                    modify (IntMap.delete worker_id)++                killAllWorkers _ =+                    get >>=+                        liftIO+                        .+                        mapM_ (killThread . workerThreadId)+                        .+                        IntMap.elems++                sendRequestToWorker request receiver worker_id =+                    get >>=+                        liftIO+                        .+                        maybe (return ()) (+                            flip request (receiver worker_id)+                            .+                            workerPendingRequests+                        )+                        .+                        IntMap.lookup worker_id++                sendProgressUpdateRequestTo = sendRequestToWorker sendProgressUpdateRequest receiveProgressUpdateFromWorker+                sendWorkloadStealRequestTo = sendRequestToWorker sendWorkloadStealRequest receiveStolenWorkloadFromWorker+                sendWorkloadTo worker_id workload =+                    (debugM $ "Sending " ++ show workload ++ " to worker " ++ show worker_id)+                    >>+                    (liftIO $+                        forkWorkerThread+                            exploration_mode+                            purity+                            (\termination_reason →+                                case termination_reason of+                                    WorkerFinished final_progress →+                                        receiveFinishedFromWorker worker_id final_progress+                                    WorkerFailed message →+                                        receiveFailureFromWorker worker_id message+                                    WorkerAborted →+                                        receiveQuitFromWorker worker_id+                            )+                            tree+                            workload+                            (case exploration_mode of+                                AllMode → absurd+                                FirstMode → absurd+                                FoundModeUsingPull _ → absurd+                                FoundModeUsingPush _ → receiveProgressUpdateFromWorker worker_id+                            )+                    )+                    >>=+                    modify+                    .+                    IntMap.insert worker_id+                    >>+                    (debugM $ "Thread for worker " ++ show worker_id ++ "started.")++            in WorkgroupCallbacks{..}+        )+        starting_progress+        controller++--------------------------------------------------------------------------------+----------------------------------- Internal -----------------------------------+--------------------------------------------------------------------------------++fromJustOrBust :: String → Maybe α → α+fromJustOrBust message = fromMaybe (error message)
+ sources/LogicGrowsOnTrees/Parallel/Common/Message.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains infrastructure for communicating with workers over an+    inter-process channel.+ -}+module LogicGrowsOnTrees.Parallel.Common.Message+    (+    -- * Types+      MessageForSupervisor(..)+    , MessageForSupervisorFor+    , MessageForSupervisorReceivers(..)+    , MessageForWorker(..)+    -- * Functions+    , receiveAndProcessMessagesFromWorker+    , receiveAndProcessMessagesFromWorkerUsingHandle+    ) where++import Data.Derive.Serialize+import Data.DeriveTH+import Data.Serialize++import qualified LogicGrowsOnTrees.Parallel.Common.Worker as Worker+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Utils.Handle+import LogicGrowsOnTrees.Workload++import System.IO (Handle)++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++{-| A message from a worker to the supervisor;  the worker id is assumed to be+    known based on from where the message was received.+ -}+data MessageForSupervisor progress worker_final_progress =+    {-| The worker encountered a failure with the given message while exploring the tree. -}+    Failed String+    {-| The worker has finished with the given final progress. -}+  | Finished worker_final_progress+    {-| The worker has responded to the progress update request with the given progress update. -}+  | ProgressUpdate (Worker.ProgressUpdate progress)+    {-| The worker has responded to the workload steal request with possibly the stolen workload (and 'Nothing' if it was not possible to steal a workload at this time). -}+  | StolenWorkload (Maybe (Worker.StolenWorkload progress))+    {-| The worker has quit the system and is no longer available -}+  | WorkerQuit+  deriving (Eq,Show)+$(derive makeSerialize ''MessageForSupervisor)++{-| Convenient type alias for the 'MessageForSupervisor' type for the given exploration mode. -}+type MessageForSupervisorFor exploration_mode = MessageForSupervisor (ProgressFor exploration_mode) (WorkerFinishedProgressFor exploration_mode)++{-| This data structure contains callbacks to be invoked when a message has+    been received, depending on the kind of message.+ -}+data MessageForSupervisorReceivers exploration_mode worker_id = MessageForSupervisorReceivers+    {   {-| to be called when a progress update has been received from a worker -}+        receiveProgressUpdateFromWorker :: worker_id → Worker.ProgressUpdate (ProgressFor exploration_mode) → IO ()+        {-| to be called when a (possibly) stolen workload has been received from a worker -}+    ,   receiveStolenWorkloadFromWorker :: worker_id → Maybe (Worker.StolenWorkload (ProgressFor exploration_mode)) → IO ()+        {-| to be called when a failure (with the given message) has been received from a worker -}+    ,   receiveFailureFromWorker :: worker_id → String → IO ()+        {-| to be called when a worker has finished with the given final progress -}+    ,   receiveFinishedFromWorker :: worker_id → WorkerFinishedProgressFor exploration_mode → IO ()+        {-| to be called when a worker has quit the system and is no longer available -}+    ,   receiveQuitFromWorker :: worker_id → IO ()+    }++{-| A message from the supervisor to a worker.++    NOTE: It is your responsibility not to send a workload to a worker that+          already has one;  if you do then the worker will report an error and+          then terminate.  The converse, however, is not true:  it is okay to+          send a progress request to a worker without a workload because the+          worker might have finished between when you sent the message and when+          it was received.+ -}+data MessageForWorker =+    RequestProgressUpdate {-^ request a progress update -}+  | RequestWorkloadSteal {-^ request a stolen workload -}+  | StartWorkload Workload {-^ start exploring the given workload -}+  | QuitWorker {-^ stop what you are doing and quit the system -}+  deriving (Eq,Show)+$(derive makeSerialize ''MessageForWorker)++{-| Continually performs the given IO action to read a message from a worker+    with the given id and calls one of the given callbacks depending on the+    content of the message.+ -}+receiveAndProcessMessagesFromWorker ::+    MessageForSupervisorReceivers exploration_mode worker_id {-^ the callbacks to invoke when a message has been received -} →+    IO (MessageForSupervisorFor exploration_mode) {-^ an action that fetches the next message -} →+    worker_id {-^ the id of the worker from which messages are being received -} →+    IO () {-^ an IO action that continually processes incoming messages from a worker until it quits, at which point it returns -}+receiveAndProcessMessagesFromWorker+    MessageForSupervisorReceivers{..}+    receiveMessage+    worker_id+    = receiveNextMessage+  where+    receiveNextMessage = receiveMessage >>= processMessage+    processMessage (Failed message) = do+        receiveFailureFromWorker worker_id message+        receiveNextMessage+    processMessage (Finished final_progress) = do+        receiveFinishedFromWorker worker_id final_progress+        receiveNextMessage+    processMessage (ProgressUpdate progress_update) = do+        receiveProgressUpdateFromWorker worker_id progress_update+        receiveNextMessage+    processMessage (StolenWorkload stolen_workload) = do+        receiveStolenWorkloadFromWorker worker_id stolen_workload+        receiveNextMessage+    processMessage WorkerQuit =+        receiveQuitFromWorker worker_id++{-| The same as 'receiveAndProcessMessagesFromWorker' except that instead of+    giving it an IO action to fetch a message you provide a 'Handle' from which+    messsages (assumed to be deserializable) are read.+ -}+receiveAndProcessMessagesFromWorkerUsingHandle ::+    ( Serialize (ProgressFor exploration_mode)+    , Serialize (WorkerFinishedProgressFor exploration_mode)+    ) ⇒+    MessageForSupervisorReceivers exploration_mode worker_id {-^ the callbacks to invoke when a message has been received -} →+    Handle {-^ the handle from which messages should be read -} →+    worker_id {-^ the id of the worker from which messages are being received -} →+    IO () {-^ an IO action that continually processes incoming messages from a worker until it quits, at which point it returns -}+receiveAndProcessMessagesFromWorkerUsingHandle receivers handle worker_id =+    receiveAndProcessMessagesFromWorker receivers (receive handle) worker_id+++
+ sources/LogicGrowsOnTrees/Parallel/Common/Process.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains functions that let one easily implement the worker side+    of an adapter under the assumption that the worker uses a two-way+    communication channel with the supervisor for sending and receiving+    messages.  (Examples of when this is NOT the case is the threads adapter,+    where you can communicate with the worker threads directly, and the MPI+    adapter, which has communication primitives that don't quite align with+    this setup.)+ -}+module LogicGrowsOnTrees.Parallel.Common.Process+    (+    -- * Exceptions+      ConnectionLost(..)+    -- * Functions+    , runWorker+    , runWorkerUsingHandles+    ) where++import Control.Concurrent (killThread)+import Control.Concurrent.MVar (isEmptyMVar,newEmptyMVar,newMVar,putMVar,takeMVar,tryTakeMVar,withMVar)+import Control.Exception (AsyncException(ThreadKilled,UserInterrupt),Handler(..),catches,throwIO)+import Control.Monad.IO.Class++import Data.Functor ((<$>))+import Data.Serialize+import Data.Void (absurd)++import System.IO (Handle)+import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(DEBUG,INFO))+import System.Log.Logger.TH++import LogicGrowsOnTrees (TreeT)+import LogicGrowsOnTrees.Parallel.Common.Message (MessageForSupervisor(..),MessageForSupervisorFor,MessageForWorker(..))+import LogicGrowsOnTrees.Parallel.Common.Worker hiding (ProgressUpdate,StolenWorkload)+import LogicGrowsOnTrees.Parallel.ExplorationMode (ProgressFor,ResultFor,ExplorationMode(..),WorkerFinishedProgressFor)+import LogicGrowsOnTrees.Parallel.Purity+import LogicGrowsOnTrees.Utils.Handle++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [DEBUG,INFO]++--------------------------------------------------------------------------------+----------------------------------- Functions ----------------------------------+--------------------------------------------------------------------------------++{-| Runs a loop that continually fetches and reacts to messages from the+    supervisor until the worker quits.+ -}+runWorker ::+    ∀ exploration_mode m n.+    ExplorationMode exploration_mode {-^ the mode in to explore the tree -} →+    Purity m n {-^ the purity of the tree -} →+    TreeT m (ResultFor exploration_mode) {-^ the tree -} →+    IO MessageForWorker {-^ the action used to fetch the next message -} →+    (MessageForSupervisorFor exploration_mode → IO ()) {-^ the action to send a message to the supervisor;  note that this might occur in a different thread from the worker loop -} →+    IO ()+runWorker exploration_mode purity tree receiveMessage sendMessage =+    -- Note:  This an MVar rather than an IORef because it is used by two+    --        threads --- this one and the worker thread --- and I wanted to use+    --        a mechanism that ensured that the new value would be observed by+    --        the other thread immediately rather than when the cache lines+    --        are flushed to the other processors.+    newEmptyMVar >>= \worker_environment_mvar →+    let processRequest ::+            (WorkerRequestQueue (ProgressFor exploration_mode) → (α → IO ()) → IO ()) →+            (α → MessageForSupervisorFor exploration_mode) →+            IO ()+        processRequest sendRequest constructResponse =+            tryTakeMVar worker_environment_mvar+            >>=+            maybe (return ()) (\worker_environment@WorkerEnvironment{workerPendingRequests} → do+                _ ← sendRequest workerPendingRequests (sendMessage . constructResponse)+                putMVar worker_environment_mvar worker_environment+            )+        processNextMessage = receiveMessage >>= \message →+            case message of+                RequestProgressUpdate → do+                    processRequest sendProgressUpdateRequest ProgressUpdate+                    processNextMessage+                RequestWorkloadSteal → do+                    processRequest sendWorkloadStealRequest StolenWorkload+                    processNextMessage+                StartWorkload workload → do+                    infoM "Received workload."+                    debugM $ "Workload is: " ++ show workload+                    worker_is_running ← not <$> isEmptyMVar worker_environment_mvar+                    if worker_is_running+                        then sendMessage $ Failed "received a workload when the worker was already running"+                        else forkWorkerThread+                                exploration_mode+                                purity+                                (\termination_reason → do+                                    _ ← takeMVar worker_environment_mvar+                                    case termination_reason of+                                        WorkerFinished final_progress →+                                            sendMessage $ Finished final_progress+                                        WorkerFailed exception →+                                            sendMessage $ Failed (show exception)+                                        WorkerAborted →+                                            return ()+                                )+                                tree+                                workload+                                (case exploration_mode of+                                    AllMode → absurd+                                    FirstMode → absurd+                                    FoundModeUsingPull _ → absurd+                                    FoundModeUsingPush _ → sendMessage . ProgressUpdate+                                )+                             >>=+                             putMVar worker_environment_mvar+                    processNextMessage+                QuitWorker → do+                    sendMessage WorkerQuit+                    liftIO $+                        tryTakeMVar worker_environment_mvar+                        >>=+                        maybe (return ()) (killThread . workerThreadId)+    in processNextMessage+        `catches`+        [Handler $ \e → case e of+            ThreadKilled → return ()+            UserInterrupt → return ()+            _ → throwIO e+        ,Handler $ \e → case e of+            ConnectionLost → debugM "Connection to supervisor was lost before this process had finished."+        ]++{-| The same as 'runWorker', but it lets you provide handles through which the+    messages will be sent and received. (Note that the reading and writing+    handles might be the same.)+ -}+runWorkerUsingHandles ::+    ( Serialize (ProgressFor exploration_mode)+    , Serialize (WorkerFinishedProgressFor exploration_mode)+    ) ⇒+    ExplorationMode exploration_mode {-^ the mode in to explore the tree -} →+    Purity m n {-^ the purity of the tree -} →+    TreeT m (ResultFor exploration_mode) {-^ the tree -} →+    Handle {-^ handle from which messages from the supervisor are read -} →+    Handle {-^ handle to which messages to the supervisor are written -} →+    IO ()+runWorkerUsingHandles exploration_mode purity tree receive_handle send_handle =+    newMVar () >>= \send_lock →+    runWorker+        exploration_mode+        purity+        tree+        (receive receive_handle)+        (withMVar send_lock . const . send send_handle)
+ sources/LogicGrowsOnTrees/Parallel/Common/RequestQueue.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DoRec #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| To understand the purpose of this module, it helps to know that there are+    two main loops running in the supervisor. The first loop runs inside the+    'SupervisorMonad' and is usually taken over by the adapter, which handles+    the communication between the supervisors and the workers. The second loop+    (referred to as the /controller/) is intended for the user to be able to+    submit requests such as a global progress update to the supervisor, or+    possibly adapter-specific requests (such as changing the number of workers).++    With this in mind, the purpose of this module is to create infrastructure+    for the second loop (the controller) to submit requests to the first loop.+    It provides this functionality through a class so that specific adapters can+    extend this to provide requests specific to that adapter (such as changing+    the number of workers).+ -}+module LogicGrowsOnTrees.Parallel.Common.RequestQueue+    (+    -- * Type-classes+      RequestQueueMonad(..)+    -- * Types+    , Request+    , RequestQueue(..)+    , RequestQueueReader+    -- * Functions+    -- ** Synchronized requests+    , getCurrentProgress+    , getNumberOfWorkers+    , requestProgressUpdate+    , syncAsync+    -- ** Request queue management+    , addProgressReceiver+    , enqueueRequest+    , enqueueRequestAndWait+    , newRequestQueue+    , tryDequeueRequest+    -- ** Request processing+    , processAllRequests+    , receiveProgress+    , requestQueueProgram+    -- ** Controller threads+    , forkControllerThread+    , killControllerThreads+    -- ** Miscellaneous+    , getQuantityAsync+    ) where++import Prelude hiding (catch)++import Control.Applicative (liftA2)+import Control.Arrow ((&&&))+import Control.Concurrent (ThreadId,forkIO,killThread)+import Control.Concurrent.MVar (newEmptyMVar,putMVar,takeMVar)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan (TChan,newTChanIO,readTChan,tryReadTChan,writeTChan)+import Control.Exception (BlockedIndefinitelyOnMVar(..),catch,finally)+import Control.Monad.CatchIO (MonadCatchIO)+import Control.Monad ((>=>),join,liftM,liftM3)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Reader (ReaderT(..),ask)++import Data.Composition ((.*))+import Data.IORef (IORef,atomicModifyIORef,readIORef,newIORef)+import Data.List (delete)++import qualified LogicGrowsOnTrees.Parallel.Common.Supervisor as Supervisor+import LogicGrowsOnTrees.Parallel.Common.Supervisor (SupervisorFullConstraint,SupervisorMonad,SupervisorProgram(..))+import LogicGrowsOnTrees.Parallel.ExplorationMode++--------------------------------------------------------------------------------+--------------------------------- Type-classes ---------------------------------+--------------------------------------------------------------------------------++{-| This class provides the set of supervisor requests common to all adapters. -}+class (HasExplorationMode m, Functor m, MonadCatchIO m) ⇒ RequestQueueMonad m where+    {-| Abort the supervisor. -}+    abort :: m ()+    {-| Fork a new thread running in this monad;  all controller threads are automnatically killed when the run is finished. -}+    fork :: m () → m ThreadId+    {-| Request the current progress, invoking the given callback with the result;  see 'getCurrentProgress' for the synchronous version. -}+    getCurrentProgressAsync :: (ProgressFor (ExplorationModeFor m) → IO ()) → m ()+    {-| Request the number of workers, invoking the given callback with the result;  see 'getNumberOfWorkers' for the synchronous version. -}+    getNumberOfWorkersAsync :: (Int → IO ()) → m ()+    {-| Request that a global progress update be performed, invoking the given callback with the result;  see 'requestProgressUpdate' for the synchronous version. -}+    requestProgressUpdateAsync :: (ProgressFor (ExplorationModeFor m) → IO ()) → m ()+    {-| Sets the size of the workload buffer;  for more information, see 'Supervisor.setWorkloadBufferSize' (which links to the "LogicGrowsOnTrees.Parallel.Common.Supervisor" module). -}+    setWorkloadBufferSize :: Int → m ()++--------------------------------------------------------------------------------+------------------------------------- Types ------------------------------------+--------------------------------------------------------------------------------++{-| A supervisor request. -}+type Request exploration_mode worker_id m = SupervisorMonad exploration_mode worker_id m ()+{-| A basic supervisor request queue. -}+data RequestQueue exploration_mode worker_id m = RequestQueue+    {   {-| the queue of requests to the supervisor -}+        requests :: !(TChan (Request exploration_mode worker_id m))+        {-| a list of callbacks to invoke when a global progress update has completed -}+    ,   receivers :: !(IORef [ProgressFor exploration_mode → IO ()])+        {-| a list of the controller threads -}+    ,   controllerThreads  :: !(IORef [ThreadId])+    }+{-| A basic supervisor request queue monad, which has an implicit 'RequestQueue'+    object that it uses to communicate with the supervisor loop.+ -}+type RequestQueueReader exploration_mode worker_id m = ReaderT (RequestQueue exploration_mode worker_id m) IO++instance HasExplorationMode (RequestQueueReader exploration_mode worker_id m) where+    type ExplorationModeFor (RequestQueueReader exploration_mode worker_id m) = exploration_mode++instance (SupervisorFullConstraint worker_id m, MonadCatchIO m) ⇒ RequestQueueMonad (RequestQueueReader exploration_mode worker_id m) where+    abort = ask >>= enqueueRequest Supervisor.abortSupervisor+    fork m = ask >>= flip forkControllerThread' m+    getCurrentProgressAsync = (ask >>=) . getQuantityAsync Supervisor.getCurrentProgress+    getNumberOfWorkersAsync = (ask >>=) . getQuantityAsync Supervisor.getNumberOfWorkers+    requestProgressUpdateAsync receiveUpdatedProgress =+        ask+        >>=+        liftIO+        .+        liftA2 (>>)+            (addProgressReceiver receiveUpdatedProgress)+            (enqueueRequest Supervisor.performGlobalProgressUpdate)+    setWorkloadBufferSize size = ask >>= enqueueRequest (Supervisor.setWorkloadBufferSize size)++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++------------------------------ Synchronized requests ------------------------------++{-| Like 'getCurrentProgressAsync', but blocks until the result is ready. -}+getCurrentProgress :: RequestQueueMonad m ⇒ m (ProgressFor (ExplorationModeFor m))+getCurrentProgress = syncAsync getCurrentProgressAsync++{-| Like 'getNumberOfWorkersAsync', but blocks until the result is ready. -}+getNumberOfWorkers :: RequestQueueMonad m ⇒ m Int+getNumberOfWorkers = syncAsync getNumberOfWorkersAsync++{-| Like 'requestProgressUpdateAsync', but blocks until the progress update has completed. -}+requestProgressUpdate :: RequestQueueMonad m ⇒ m (ProgressFor (ExplorationModeFor m))+requestProgressUpdate = syncAsync requestProgressUpdateAsync++{-| General utility function for converting an asynchronous request to a+    synchronous request;  it uses an 'MVar' to hold the result of the request and+    blocks until the 'MVar' has been filled.+ -}+syncAsync :: MonadIO m ⇒ ((α → IO ()) → m ()) → m α+syncAsync runCommandAsync = do+    result_mvar ← liftIO newEmptyMVar+    runCommandAsync (putMVar result_mvar)+    liftIO $+        takeMVar result_mvar+        `catch`+        (\BlockedIndefinitelyOnMVar → error $ "blocked forever while waiting for controller to respond to request")++---------------------------- Request queue management -----------------------------++{-| Adds a callback to the given 'RequestQueue' that will be invoked when the current global progress update has completed. -}+addProgressReceiver ::+    MonadIO m' ⇒+    (ProgressFor exploration_mode → IO ()) →+    RequestQueue exploration_mode worker_id m →+    m' ()+addProgressReceiver receiver =+    liftIO+    .+    flip atomicModifyIORef ((receiver:) &&& const ())+    .+    receivers++{-| Enqueues a supervisor request into the given queue. -}+enqueueRequest ::+    MonadIO m' ⇒+    Request exploration_mode worker_id m →+    RequestQueue exploration_mode worker_id m →+    m' ()+enqueueRequest = flip $+    (liftIO . atomically)+    .*+    (writeTChan . requests)++{-| Like 'enqueueRequest', but does not return until the request has been run -}+enqueueRequestAndWait ::+    (MonadIO m, MonadIO m') ⇒+    Request exploration_mode worker_id m →+    RequestQueue exploration_mode worker_id m →+    m' ()+enqueueRequestAndWait request request_queue = do+    signal ← liftIO newEmptyMVar+    enqueueRequest (request >> liftIO (putMVar signal ())) request_queue+    liftIO $ takeMVar signal++{-| Constructs a new 'RequestQueue'. -}+newRequestQueue ::+    MonadIO m' ⇒+    m' (RequestQueue exploration_mode worker_id m)+newRequestQueue = liftIO $ liftM3 RequestQueue newTChanIO (newIORef []) (newIORef [])++{-| Attempt to pop a request from the 'RequestQueue'. -}+tryDequeueRequest ::+    MonadIO m' ⇒+    RequestQueue exploration_mode worker_id m →+    m' (Maybe (Request exploration_mode worker_id m))+tryDequeueRequest =+    liftIO+    .+    atomically+    .+    tryReadTChan+    .+    requests++------------------------------- Request processing --------------------------------++{-| Processes all of the requests in the given 'RequestQueue', and returns when+    the queue has been emptied.+ -}+processAllRequests ::+    MonadIO m ⇒+    RequestQueue exploration_mode worker_id m →+    SupervisorMonad exploration_mode worker_id m ()+processAllRequests (RequestQueue requests _ _) = go+  where+    go =+        (liftIO . atomically . tryReadTChan) requests+        >>=+        maybe (return ()) (>> go)++{-| Invokes all of the callbacks with the given progress and then clears the list of callbacks. -}+receiveProgress ::+    MonadIO m' ⇒+    RequestQueue exploration_mode worker_id m →+    ProgressFor exploration_mode →+    m' ()+receiveProgress queue progress =+    liftIO+    .+    join+    .+    liftM (sequence_ . map ($ progress))+    .+    flip atomicModifyIORef (const [] &&& id)+    .+    receivers+    $+    queue++{-| Creates a supervisor program that loops forever processing requests from the given queue. -}+requestQueueProgram ::+    MonadIO m ⇒+    SupervisorMonad exploration_mode worker_id m () {-^ initialization code to run before the loop is started -} →+    RequestQueue exploration_mode worker_id m {-^ the request queue -} →+    SupervisorProgram exploration_mode worker_id m+requestQueueProgram initialize =+    flip (BlockingProgram initialize) id+    .+    liftIO+    .+    atomically+    .+    readTChan+    .+    requests++------------------------------ Controller threads ------------------------------++{-| Forks a controller thread;  it's 'ThreadId' is added the list in the request+    queue. We deliberately do not return the 'ThreadId' from this function+    because you must always call `killControllerThreads` to kill the controller+    thread as this makes sure that all child threads also get killed.+ -}+forkControllerThread ::+    MonadIO m' ⇒+    RequestQueue exploration_mode worker_id m {-^ the request queue -} →+    RequestQueueReader exploration_mode worker_id m () {-^ the controller thread -} →+    m' ()+forkControllerThread = liftM (const ()) .* forkControllerThread'++forkControllerThread' ::+    MonadIO m' ⇒+    RequestQueue exploration_mode worker_id m →+    RequestQueueReader exploration_mode worker_id m () →+    m' ThreadId+forkControllerThread' request_queue controller = liftIO $ do+    start_signal ← newEmptyMVar+    rec thread_id ←+            forkIO+            $+            (takeMVar start_signal >> runReaderT controller request_queue)+            `finally`+            (atomicModifyIORef (controllerThreads request_queue) (delete thread_id &&& const ()))+    atomicModifyIORef (controllerThreads request_queue) ((thread_id:) &&& const ())+    {- NOTE:  The following signal is needed because we don't want the new+              thread to start until after its thread id has been added to the+              list, as otherwise it could result in an orphan thread that won't+              get garbage collected until the supervisor finishes due to a+              peculiarity of the GHC runtime where it doesn't garbage collect a+              thread as long as a ThreadId referring to it exists.+     -}+    putMVar start_signal ()+    return thread_id++{-| Kill all the controller threads and their children. -}+killControllerThreads ::+    MonadIO m' ⇒+    RequestQueue exploration_mode worker_id m {-^ the request queue -} →+    m' ()+killControllerThreads = liftIO . readIORef . controllerThreads >=> liftIO . mapM_ killThread++---------------------------------- Miscellaneous ----------------------------------++{-| Submits a 'Request' to the supervisor and invokes the given callback with the+    result when it is available.  (This function is used by+    'getCurrentProgressAsync' and 'getNumberOfWorkersAsync'.)+ -}+getQuantityAsync ::+    ( MonadIO m'+    , SupervisorFullConstraint worker_id m+    ) ⇒+    SupervisorMonad exploration_mode worker_id m α →+    (α → IO ()) →+    RequestQueue exploration_mode worker_id m →+    m' ()+getQuantityAsync getQuantity receiveQuantity =+    enqueueRequest $ getQuantity >>= liftIO . receiveQuantity
+ sources/LogicGrowsOnTrees/Parallel/Common/Supervisor.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- needed to define the MTL instances :-/+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}++{-| The Supervisor module contains logic that is common to all of the adapters+    for the parallization infrastructure. The way to use it is to package the+    logic for communicating with your workers into a 'SupervisorProgram' that+    runs in the 'SupervisorMonad' with your state just below the+    'SupervisorMonad' in the monad stack.++    A great deal of the logic in this module deals with gathering statistics+    whose purpose is to provide data that can be used to figure out what is+    going wrong if the runtime is not scaling inversely with the number of+    workers.+ -}+module LogicGrowsOnTrees.Parallel.Common.Supervisor+    (+    -- * Types+    -- ** Statistics+      FunctionOfTimeStatistics(..)+    , IndependentMeasurementsStatistics(..)+    , RunStatistics(..)+    -- ** Constraints+    , SupervisorFullConstraint+    , SupervisorMonadConstraint+    , SupervisorWorkerIdConstraint+    -- ** Supervisor types+    , SupervisorCallbacks(..)+    , SupervisorMonad+    , SupervisorOutcome(..)+    , SupervisorOutcomeFor+    , SupervisorProgram(..)+    , SupervisorTerminationReason(..)+    , SupervisorTerminationReasonFor+    -- * Functions+    -- ** Worker interaction+    , addWorker+    , performGlobalProgressUpdate+    , receiveProgressUpdate+    , receiveStolenWorkload+    , receiveWorkerFailure+    , receiveWorkerFinished+    , receiveWorkerFinishedAndRemoved+    , receiveWorkerFinishedWithRemovalFlag+    , removeWorker+    , removeWorkerIfPresent+    -- ** Supervisor interaction+    , abortSupervisor+    , beginSupervisorOccupied+    , disableSupervisorDebugMode+    , enableSupervisorDebugMode+    , endSupervisorOccupied+    , setSupervisorDebugMode+    , setWorkloadBufferSize+    -- ** Inquiries+    , getCurrentProgress+    , getCurrentStatistics+    , getNumberOfWorkers+    , tryGetWaitingWorker+    -- ** Launching the supervisor+    , runSupervisor+    , runSupervisorStartingFrom+    -- ** Testing the supervisor+    , runUnrestrictedSupervisor+    , runUnrestrictedSupervisorStartingFrom+    ) where+++import Control.Applicative (Applicative)+import Control.Lens.Setter ((.~),(+=))+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))++import Data.Time.Clock (diffUTCTime,getCurrentTime)+import Data.Composition ((.*),(.**))++import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(DEBUG))+import System.Log.Logger.TH++import LogicGrowsOnTrees.Parallel.Common.Worker (ProgressUpdateFor,StolenWorkloadFor)+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Path (WalkError(..))++import qualified LogicGrowsOnTrees.Parallel.Common.Supervisor.Implementation as Implementation+import LogicGrowsOnTrees.Parallel.Common.Supervisor.Implementation+    ( AbortMonad()+    , ContextMonad()+    , FunctionOfTimeStatistics(..)+    , IndependentMeasurementsStatistics(..)+    , RunStatistics(..)+    , SupervisorCallbacks(..)+    , SupervisorFullConstraint+    , SupervisorMonadConstraint+    , SupervisorOutcome(..)+    , SupervisorOutcomeFor+    , SupervisorTerminationReason(..)+    , SupervisorTerminationReasonFor+    , SupervisorWorkerIdConstraint+    , current_time+    , liftContextToAbort+    , liftUserToAbort+    , number_of_calls+    , time_spent_in_supervisor_monad+    )++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [DEBUG]++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++---------------------- Supervisor monad and program types ----------------------++{-| This is the monad in which the supervisor logic is run;  it keeps track of+    the state of the system including the current workers and their workloads,+    the current progress of the system, which workers we are waiting for a+    progress update or stolen workload from, etc.+ -}+newtype SupervisorMonad exploration_mode worker_id m α =+    SupervisorMonad {+        unwrapSupervisorMonad :: AbortMonad exploration_mode worker_id m α+    } deriving (Applicative,Functor,Monad,MonadIO)++instance MonadTrans (SupervisorMonad exploration_mode worker_id) where+    lift = SupervisorMonad . liftUserToAbort++instance MonadReader e m ⇒ MonadReader e (SupervisorMonad exploration_mode worker_id m) where+    ask = lift ask+    local f = SupervisorMonad . Implementation.localWithinAbort f . unwrapSupervisorMonad++instance MonadState s m ⇒ MonadState s (SupervisorMonad exploration_mode worker_id m) where+    get = lift get+    put = lift . put++{-| A 'SupervisorProgram' is a specification of an event loop to be run inside+    the 'SupervisorMonad';  it exists in order to help the supervisor get an+    estimate for how much time it is spending doing work as opposed to waiting+    for a message from a worker so that it can generate accurate statistics+    about how much of the time it was occupied at the end of the run.+ -}+data SupervisorProgram exploration_mode worker_id m =+    {-| A 'BlockingProgram' has an event loop that executes an action that+        pauses the thread until an event occurs and then reacts to that event.+        The first argument is the supervisor action that initializes the system,+        the second argument is an action that blocks until an event has+        occurred, and the third argument is the supervisor action to run in+        response to the event.+     -}+    ∀ α. BlockingProgram (SupervisorMonad exploration_mode worker_id m ()) (m α) (α → SupervisorMonad exploration_mode worker_id m ())+    {-| A 'PollingProgram' has an event loop that executes an action that+        checks whether an event has occurred and if so then reacts to that+        event. The first argument is the supervisor action that initializes the+        system, the second argument is an action that checks whether an event+        has occurred, and the third argument is the supervisor action to run in+        response to an event.+     -}+  | ∀ α. PollingProgram (SupervisorMonad exploration_mode worker_id m ()) (m (Maybe α)) (α → SupervisorMonad exploration_mode worker_id m ())+    {-| An 'UnrestrictedProgram' is an event loop that you implement manually;+        note that it must run forever until the logic in the 'SupervisorMonad'+        decides to exit --- although you can always force it to abort by calling+        'abortSupervisor'.  This mode exists for testing rather than to be used+        by an adapter, but if you do use it then you take on responsibility for+        calling 'beginSupervisorOccupied' and 'endSupervisorOccupied' when+        respectively the supervisor has begun and ended processing events so+        that the supervisor occupation statistics are correct.+     -}+  | UnrestrictedProgram (∀ α. SupervisorMonad exploration_mode worker_id m α)++------------------------ Wrapper convenience type-class ------------------------++class WrappableIntoSupervisorMonad w where+    wrapIntoSupervisorMonad :: MonadIO m ⇒ w exploration_mode worker_id m α → SupervisorMonad exploration_mode worker_id m α++instance WrappableIntoSupervisorMonad AbortMonad where+    wrapIntoSupervisorMonad action = do+        time_at_entrance ← liftIO getCurrentTime+        result ← SupervisorMonad . local (current_time .~ time_at_entrance) $ do+            number_of_calls += 1+            debugM "Entering SupervisorMonad"+            result ← action+            debugM "Exiting SupervisorMonad"+            liftIO getCurrentTime >>= (time_spent_in_supervisor_monad +=) . (flip diffUTCTime time_at_entrance)+            return result+        return result++instance WrappableIntoSupervisorMonad ContextMonad where+    wrapIntoSupervisorMonad = wrapIntoSupervisorMonad . liftContextToAbort++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++------------------------------ Worker interaction ------------------------------++{-| Informs the supervisor that a worker has been added to the system;  the+    supervisor will attempt to obtain a workload for it, stealing one if+    necessary.+ -}+addWorker ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    SupervisorMonad exploration_mode worker_id m ()+addWorker = wrapIntoSupervisorMonad . Implementation.addWorker++{-| Request that a global progress update be performed;  the supervisor will+    send progress update requests to all workers, and when it has received a+    response from everyone it will call the 'receiveCurrentProgress' callback in+    the 'SupervisorCallbacks'.+ -}+performGlobalProgressUpdate ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    SupervisorMonad exploration_mode worker_id m ()+performGlobalProgressUpdate = wrapIntoSupervisorMonad Implementation.performGlobalProgressUpdate++{-| Informs the supervisor that a progress update has been received by a worker. -}+receiveProgressUpdate ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ProgressUpdateFor exploration_mode →+    SupervisorMonad exploration_mode worker_id m ()+receiveProgressUpdate = wrapIntoSupervisorMonad .* Implementation.receiveProgressUpdate++{-| Informs the supervisor that a worker has responded to a workload steal+    request;  a 'Nothing' indicates that the worker did not have a workload that+    could be stolen (which occurs if it hadn't taken any branches at the time+    the request was received).+ -}+receiveStolenWorkload ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    Maybe (StolenWorkloadFor exploration_mode) →+    SupervisorMonad exploration_mode worker_id m ()+receiveStolenWorkload = wrapIntoSupervisorMonad .* Implementation.receiveStolenWorkload++{-| Informs the supervisor that a worker has failed;  the system will be+    terminated and the given message returned as the failure message.+ -}+receiveWorkerFailure :: SupervisorFullConstraint worker_id m ⇒ worker_id → String → SupervisorMonad exploration_mode worker_id m α+receiveWorkerFailure worker_id message = do+    current_progress ← getCurrentProgress+    wrapIntoSupervisorMonad+        .+        Implementation.abortSupervisorWithReason+        .+        SupervisorFailure current_progress worker_id+        $+        if message == show TreeEndedBeforeEndOfWalk ||+           message == show PastTreeIsInconsistentWithPresentTree+            then "The given checkpoint is not consistent with the given tree."+            else message++{-| Informs the supervisor that a worker has finished its current workload and+    returned the given final progress.+ -}+receiveWorkerFinished ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    WorkerFinishedProgressFor exploration_mode →+    SupervisorMonad exploration_mode worker_id m ()+receiveWorkerFinished = receiveWorkerFinishedWithRemovalFlag False++{-| Informs the supervisor that a worker has finished its current workload and+    returned the given final progress; the worker will be removed after its+    final progress has been processed.+ -}+receiveWorkerFinishedAndRemoved ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    WorkerFinishedProgressFor exploration_mode →+    SupervisorMonad exploration_mode worker_id m ()+receiveWorkerFinishedAndRemoved = receiveWorkerFinishedWithRemovalFlag True++{-| Informs the supervisor that a worker has finished its current workload and+    returned the given final progress;  if the first argument is 'True' then the+    worker will be removed.+ -}+receiveWorkerFinishedWithRemovalFlag ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Bool →+    worker_id →+    WorkerFinishedProgressFor exploration_mode →+    SupervisorMonad exploration_mode worker_id m ()+receiveWorkerFinishedWithRemovalFlag = wrapIntoSupervisorMonad .** Implementation.receiveWorkerFinishedWithRemovalFlag++{-| Informs the supervisor that a worker (which might have been active and+    possibly even waited on for a progress update and/or stolen workload) has+    been removed; the worker will be removed from the set of workers with+    pending requests and its workload will be returned to the pool of available+    workloads.+ -}+removeWorker ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    SupervisorMonad exploration_mode worker_id m ()+removeWorker = wrapIntoSupervisorMonad . Implementation.removeWorker++{-| Like 'removeWorker', but only acts if the worker is present. -}+removeWorkerIfPresent ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    SupervisorMonad exploration_mode worker_id m ()+removeWorkerIfPresent = wrapIntoSupervisorMonad . Implementation.removeWorkerIfPresent++---------------------------- Supervisor interaction ----------------------------++{-| Aborts the supervisor. -}+abortSupervisor :: SupervisorFullConstraint worker_id m ⇒ SupervisorMonad exploration_mode worker_id m α+abortSupervisor = wrapIntoSupervisorMonad Implementation.abortSupervisor++{-| Signals that the supervisor has begun processing an event. -}+beginSupervisorOccupied :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m ()+beginSupervisorOccupied = changeSupervisorOccupiedStatus True++{-| Changes the occupied status of the supervisor. -}+changeSupervisorOccupiedStatus :: SupervisorMonadConstraint m ⇒ Bool → SupervisorMonad exploration_mode worker_id m ()+changeSupervisorOccupiedStatus = wrapIntoSupervisorMonad . Implementation.changeSupervisorOccupiedStatus++{-| Signals that the supervisor has finished processing an event. -}+endSupervisorOccupied :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m ()+endSupervisorOccupied = changeSupervisorOccupiedStatus False++{-| Sets the workload buffer size, which is the minimum number of workloads that+    the supervisor will attempt to have available at all times so that requests+    for new workloads from workers can be responded to immediately.++    Normally the default value of 4 will be fine, but if you run into a problem+    where the amount of time needed to steal a workload is greater than the+    average time between requests for new workloads, then setting this to be+    proportional to the time needed to steal a workload divided by the time+    between workload requests may help.+ -}+setWorkloadBufferSize :: SupervisorMonadConstraint m ⇒ Int → SupervisorMonad exploration_mode worker_id m ()+setWorkloadBufferSize = wrapIntoSupervisorMonad . Implementation.setWorkloadBufferSize++---------------------------------- Inquiries -----------------------------------++{-| Gets the current progress of the system. -}+getCurrentProgress ::+    ( SupervisorMonadConstraint m+    ) ⇒ SupervisorMonad exploration_mode worker_id m (ProgressFor exploration_mode)+getCurrentProgress = wrapIntoSupervisorMonad Implementation.getCurrentProgress++{-| Gets the current statistics of the system. (Unlike the other \"get\"+    operations, there is a small but non-zero cost to do this as the statistics+    exist in an intermediate state that needs to be finalized.)+ -}+getCurrentStatistics ::+    SupervisorFullConstraint worker_id m ⇒+    SupervisorMonad exploration_mode worker_id m RunStatistics+getCurrentStatistics = SupervisorMonad Implementation.getCurrentStatistics++{-| Gets the number of workers that are currently present in the system. -}+getNumberOfWorkers :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m Int+getNumberOfWorkers = wrapIntoSupervisorMonad Implementation.getNumberOfWorkers++{-| If there exists any workers waiting for a workload, it returns the id of one+    of them wrapped in 'Just'; it not, it returns 'Nothing'. (This is useful,+    for example, if you want to reduce the number of workers as it is best to+    start by removing ones that are currently idle.)+ -}+tryGetWaitingWorker ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    SupervisorMonad exploration_mode worker_id m (Maybe worker_id)+tryGetWaitingWorker = wrapIntoSupervisorMonad Implementation.tryGetWaitingWorker++---------------------------------- Debugging -----------------------------------++{-| Turns off debug mode;  for more details see 'setSupervisorDebugMode'. -}+disableSupervisorDebugMode :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m ()+disableSupervisorDebugMode = setSupervisorDebugMode False++{-| Turns on debug mode;  for more details see 'setSupervisorDebugMode'. -}+enableSupervisorDebugMode :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m ()+enableSupervisorDebugMode = setSupervisorDebugMode True++{-| Sets whether the supervisor is in debug mode;  when it is in this mode it+    performs continuous self-consistency checks.  This mode is intended for+    assisting in debugging new adapters.+ -}+setSupervisorDebugMode :: SupervisorMonadConstraint m ⇒ Bool → SupervisorMonad exploration_mode worker_id m ()+setSupervisorDebugMode = wrapIntoSupervisorMonad . Implementation.setSupervisorDebugMode++--------------------------- Launching the supervisor ---------------------------++{-| Runs the supervisor in the given exploration mode with the given callbacks+    and program.+ -}+runSupervisor ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ExplorationMode exploration_mode →+    SupervisorCallbacks exploration_mode worker_id m →+    SupervisorProgram exploration_mode worker_id m →+    m (SupervisorOutcomeFor exploration_mode worker_id)+runSupervisor exploration_mode = runSupervisorStartingFrom exploration_mode (initialProgress exploration_mode)++{-| Like 'runSupervisor' but starting from the given progress. -}+runSupervisorStartingFrom ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ExplorationMode exploration_mode →+    ProgressFor exploration_mode →+    SupervisorCallbacks exploration_mode worker_id m →+    SupervisorProgram exploration_mode worker_id m →+    m (SupervisorOutcomeFor exploration_mode worker_id)+runSupervisorStartingFrom exploration_mode starting_progress callbacks program =+    Implementation.runSupervisorStartingFrom+        exploration_mode+        starting_progress+        callbacks+        (unwrapSupervisorMonad . runSupervisorProgram $ program)++{-| Converts a supervisor program into an infinite loop in the 'SupervisorMonad'. -}+runSupervisorProgram ::+    SupervisorMonadConstraint m ⇒+    SupervisorProgram exploration_mode worker_id m →+    SupervisorMonad exploration_mode worker_id m α+runSupervisorProgram program =+    case program of+        BlockingProgram initialize getRequest processRequest → initialize >> forever (do+            debugM "Supervisor waiting for request."+            request ← lift getRequest+            debugM "Supervisor request has arrived; processing request..."+            beginSupervisorOccupied+            processRequest request+            endSupervisorOccupied+            debugM "...Supervisor finished processing request."+         )+        PollingProgram initialize getMaybeRequest processRequest → initialize >> forever (do+            maybe_request ← lift getMaybeRequest+            case maybe_request of+                Nothing → endSupervisorOccupied+                Just request → do+                    beginSupervisorOccupied+                    processRequest request+         )+        UnrestrictedProgram run → run++---------------------------- Testing the supervisor ----------------------------++{- $testing+The functions in this section are intended for testing purposes and normally+should not be used+ -}++{-| Runs the supervisor with a raw action in the 'SupervisorMonad'.++    NOTE:  You should not normally use this function, as it exists primarily for+           testing purposes;  see 'SupervisorProgram' for details.+ -}+runUnrestrictedSupervisor ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ExplorationMode exploration_mode →+    SupervisorCallbacks exploration_mode worker_id m →+    (∀ α. SupervisorMonad exploration_mode worker_id m α) →+    m (SupervisorOutcomeFor exploration_mode worker_id)+runUnrestrictedSupervisor exploration_mode callbacks =+    runSupervisorStartingFrom exploration_mode (initialProgress exploration_mode) callbacks+    .+    UnrestrictedProgram++{-| Like 'runUnrestrictedSupervisor' but starting from the given progress. -}+runUnrestrictedSupervisorStartingFrom ::+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ExplorationMode exploration_mode →+    ProgressFor exploration_mode →+    SupervisorCallbacks exploration_mode worker_id m →+    (∀ α. SupervisorMonad exploration_mode worker_id m α) →+    m (SupervisorOutcomeFor exploration_mode worker_id)+runUnrestrictedSupervisorStartingFrom exploration_mode starting_progress callbacks =+    runSupervisorStartingFrom exploration_mode starting_progress callbacks+    .+    UnrestrictedProgram
+ sources/LogicGrowsOnTrees/Parallel/Common/Supervisor/Implementation.hs view
@@ -0,0 +1,1533 @@+-- Language extensions {{{+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}+-- }}}++module LogicGrowsOnTrees.Parallel.Common.Supervisor.Implementation -- {{{+    ( AbortMonad()+    , ContextMonad()+    , FunctionOfTimeStatistics(..)+    , RunStatistics(..)+    , SupervisorCallbacks(..)+    , SupervisorFullConstraint+    , SupervisorMonadConstraint+    , SupervisorOutcome(..)+    , SupervisorOutcomeFor+    , SupervisorTerminationReason(..)+    , SupervisorTerminationReasonFor+    , SupervisorWorkerIdConstraint+    , IndependentMeasurementsStatistics(..)+    , abortSupervisor+    , abortSupervisorWithReason+    , addWorker+    , changeSupervisorOccupiedStatus+    , current_time+    , getCurrentProgress+    , getCurrentStatistics+    , getNumberOfWorkers+    , liftContextToAbort+    , liftUserToAbort+    , localWithinAbort+    , localWithinContext+    , number_of_calls+    , performGlobalProgressUpdate+    , receiveProgressUpdate+    , receiveStolenWorkload+    , receiveWorkerFinishedWithRemovalFlag+    , removeWorker+    , removeWorkerIfPresent+    , runSupervisorStartingFrom+    , setSupervisorDebugMode+    , setWorkloadBufferSize+    , time_spent_in_supervisor_monad+    , tryGetWaitingWorker+    ) where -- }}}++-- Imports {{{+import Control.Applicative ((<$>),(<*>),Applicative,liftA2)+import Control.Arrow ((&&&),first)+import Control.Category ((>>>))+import Control.Exception (Exception(..),throw)+import Control.Lens ((&))+import Control.Lens.Getter ((^.),use,view)+import Control.Lens.Setter ((.~),(+~),(.=),(%=),(+=))+import Control.Lens.Internal.Zoom (Zoomed)+import Control.Lens.Lens ((<%=),(<<%=),(<<.=),(%%=),(<<.=),Lens')+import Control.Lens.TH (makeLenses)+import Control.Lens.Zoom (Zoom(..))+import Control.Monad ((>=>),liftM,liftM2,mplus,unless,void,when)+import Control.Monad.IO.Class (MonadIO,liftIO)+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Reader (asks)+import Control.Monad.Tools (ifM,whenM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Abort (AbortT(..),abort,runAbortT,unwrapAbortT)+import Control.Monad.Trans.Abort.Instances.MTL ()+import Control.Monad.Trans.Reader (ReaderT,runReaderT)+import Control.Monad.Trans.State.Strict (StateT,evalStateT,execState,execStateT,runStateT)++import Data.Composition ((.*))+import Data.Derive.Monoid+import Data.DeriveTH+import qualified Data.Foldable as Fold+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.List (inits)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromJust,fromMaybe,isJust,isNothing)+import Data.Monoid ((<>),Monoid(..))+import Data.Monoid.Statistics (StatMonoid(..))+import Data.Monoid.Statistics.Numeric (CalcCount(..),CalcMean(..),CalcVariance(..),Min(..),Max(..),Variance(..),calcStddev)+import qualified Data.MultiSet as MultiSet+import Data.MultiSet (MultiSet)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Sequence as Seq+import Data.Typeable (Typeable)+import qualified Data.Time.Clock as Clock+import Data.Time.Clock (NominalDiffTime,UTCTime,diffUTCTime)+import Data.Word (Word)++import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(DEBUG,INFO))+import System.Log.Logger.TH++import Text.Printf++import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Path++import LogicGrowsOnTrees.Parallel.Common.Worker+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Workload+-- }}}++-- Logging Functions {{{+deriveLoggers "Logger" [DEBUG,INFO]+-- }}}++-- Exceptions {{{++-- InconsistencyError {{{+data InconsistencyError = -- {{{+    IncompleteWorkspace Checkpoint+  | OutOfSourcesForNewWorkloads+  | SpaceFullyExploredButSearchNotTerminated+  deriving (Eq,Typeable)+-- }}}+instance Show InconsistencyError where -- {{{+    show (IncompleteWorkspace workspace) = "Full workspace is incomplete: " ++ show workspace+    show OutOfSourcesForNewWorkloads = "The search is incomplete but there are no sources of workloads available."+    show SpaceFullyExploredButSearchNotTerminated = "The space has been fully explored but the search was not terminated."+-- }}}+instance Exception InconsistencyError+-- }}}++-- WorkerManagementError {{{+data WorkerManagementError worker_id = -- {{{+    ActiveWorkersRemainedAfterSpaceFullyExplored [worker_id]+  | ConflictingWorkloads (Maybe worker_id) Path (Maybe worker_id) Path+  | SpaceFullyExploredButWorkloadsRemain [(Maybe worker_id,Workload)]+  | WorkerAlreadyKnown String worker_id+  | WorkerAlreadyHasWorkload worker_id+  | WorkerNotKnown String worker_id+  | WorkerNotActive String worker_id+  deriving (Eq,Typeable)+ -- }}}+instance Show worker_id ⇒ Show (WorkerManagementError worker_id) where -- {{{+    show (ActiveWorkersRemainedAfterSpaceFullyExplored worker_ids) = "Worker ids " ++ show worker_ids ++ " were still active after the space was supposedly fully explored."+    show (ConflictingWorkloads wid1 path1 wid2 path2) =+        "Workload " ++ f wid1 ++ " with initial path " ++ show path1 ++ " conflicts with workload " ++ f wid2 ++ " with initial path " ++ show path2 ++ "."+      where+        f Nothing = "sitting idle"+        f (Just wid) = "of worker " ++ show wid+    show (SpaceFullyExploredButWorkloadsRemain workers_and_workloads) = "The space has been fully explored, but the following workloads remain: " ++ show workers_and_workloads+    show (WorkerAlreadyKnown action worker_id) = "Worker id " ++ show worker_id ++ " already known when " ++ action ++ "."+    show (WorkerAlreadyHasWorkload worker_id) = "Attempted to send workload to worker id " ++ show worker_id ++ " which is already active."+    show (WorkerNotKnown action worker_id) = "Worker id " ++ show worker_id ++ " not known when " ++ action ++ "."+    show (WorkerNotActive action worker_id) = "Worker id " ++ show worker_id ++ " not active when " ++ action ++ "."+-- }}}+instance (Eq worker_id, Show worker_id, Typeable worker_id) ⇒ Exception (WorkerManagementError worker_id)+-- }}}++-- SupervisorError {{{+data SupervisorError worker_id = -- {{{+    SupervisorInconsistencyError InconsistencyError+  | SupervisorWorkerManagementError (WorkerManagementError worker_id)+  deriving (Eq,Typeable)+-- }}}+instance Show worker_id ⇒ Show (SupervisorError worker_id) where -- {{{+    show (SupervisorInconsistencyError e) = show e+    show (SupervisorWorkerManagementError e) = show e+-- }}}+instance (Eq worker_id, Show worker_id, Typeable worker_id) ⇒ Exception (SupervisorError worker_id) where -- {{{+    toException (SupervisorInconsistencyError e) = toException e+    toException (SupervisorWorkerManagementError e) = toException e+    fromException e =+        (SupervisorInconsistencyError <$> fromException e)+        `mplus`+        (SupervisorWorkerManagementError <$> fromException e)+-- }}}+-- }}}++-- }}}++-- Types {{{++-- Statistics {{{++data ExponentiallyDecayingSum = ExponentiallyDecayingSum -- {{{+    {   _last_decaying_sum_timestamp :: !UTCTime+    ,   _decaying_sum_value :: !Float+    } deriving (Eq,Show)+$( makeLenses ''ExponentiallyDecayingSum )+-- }}}++data ExponentiallyWeightedAverage = ExponentiallyWeightedAverage -- {{{+    {   _last_average_timestamp :: !UTCTime+    ,   _current_average_value :: !Float+    } deriving (Eq,Show)+$( makeLenses ''ExponentiallyWeightedAverage )+-- }}}++{-| Statistics for a value obtained by integrating a value that is a function of+    time --- i.e., a quantity that holds a single value at any given point in+    time.+ -}+data FunctionOfTimeStatistics α = FunctionOfTimeStatistics -- {{{+    {   timeCount :: !Word {-^ the number of points at which the function changed -}+    ,   timeAverage :: !Double {-^ the average value of the function over the time period -}+    ,   timeStdDev :: !Double {-^ the standard deviation of the function over the time period -}+    ,   timeMin :: !α {-^ the minimum value of the function over the time period -}+    ,   timeMax :: !α {-^ the maximum value of the function over the time period -}+    } deriving (Eq,Show)+-- }}}++data RetiredOccupationStatistics = RetiredOccupationStatistics -- {{{+    {   _occupied_time :: !NominalDiffTime+    ,   _total_time :: !NominalDiffTime+    } deriving (Eq,Show)+$( makeLenses ''RetiredOccupationStatistics )+-- }}}++data OccupationStatistics = OccupationStatistics -- {{{+    {   _start_time :: !UTCTime+    ,   _last_occupied_change_time :: !UTCTime+    ,   _total_occupied_time :: !NominalDiffTime+    ,   _is_currently_occupied :: !Bool+    } deriving (Eq,Show)+$( makeLenses ''OccupationStatistics )+-- }}}++{-| Statistics gathered about the run. -}+data RunStatistics = -- {{{+    RunStatistics+    {   runStartTime :: !UTCTime {-^ the start time of the run -}+    ,   runEndTime :: !UTCTime {-^ the end time of the run -}+    ,   runWallTime :: !NominalDiffTime {-^ the wall time of the run -}+    ,   runSupervisorOccupation :: !Float {-^ the fraction of the time the supervisor spent processing events -}+    ,   runSupervisorMonadOccupation :: !Float {-^ the fraction of the time the supervisor spent processing events while inside the 'SupervisorMonad' -}+    ,   runNumberOfCalls :: !Int {-^ the number of calls made to functions in "LogicGrowsOnTrees.Parallel.Common.Supervisor" -}+    ,   runAverageTimePerCall :: !Float {-^ the average amount of time per call made to functions in "LogicGrowsOnTrees.Parallel.Common.Supervisor" -}+    ,   runWorkerOccupation :: !Float {-^ the fraction of the total time that workers were occupied -}+    ,   runWorkerWaitTimes :: !(FunctionOfTimeStatistics NominalDiffTime) {-^ statistics for how long it took for workers to obtain a workload -}+    ,   runStealWaitTimes :: !IndependentMeasurementsStatistics {-^ statistics for the time needed to steal a workload from a worker -}+    ,   runWaitingWorkerStatistics :: !(FunctionOfTimeStatistics Int) {-^ statistics for the number of workers waiting for a workload -}+    ,   runAvailableWorkloadStatistics :: !(FunctionOfTimeStatistics Int) {-^ statistics for the number of available workloads waiting for a worker -}+    ,   runInstantaneousWorkloadRequestRateStatistics :: !(FunctionOfTimeStatistics Float) {-^ statistics for the instantaneous rate at which workloads were requested (using an exponentially decaying sum) -}+    ,   runInstantaneousWorkloadStealTimeStatistics :: !(FunctionOfTimeStatistics Float) {-^ statistics for the instantaneous time needed for workloads to be stolen (using an exponentially decaying weighted average) -}+    } deriving (Eq,Show)+-- }}}++{-| Statistics for a value obtained by collecting a number of independent measurements. -}+data IndependentMeasurementsStatistics = IndependentMeasurementsStatistics -- {{{+    {   statCount :: {-# UNPACK #-} !Int {-^ the number of measurements -}+    ,   statAverage :: {-# UNPACK #-} !Double {-^ the average value -}+    ,   statStdDev ::  {-# UNPACK #-} !Double {-^ the standard deviation -}+    ,   statMin :: {-# UNPACK #-} !Double {-^ the minimum measurement value -}+    ,   statMax :: {-# UNPACK #-} !Double {-^ the maximum measurement value -}+    } deriving (Eq,Show)+-- }}}++data IndependentMeasurements = IndependentMeasurements -- {{{+    {   timeDataMin :: {-# UNPACK #-} !Min+    ,   timeDataMax :: {-# UNPACK #-} !Max+    ,   timeDataVariance ::  {-# UNPACK #-} !Variance+    } deriving (Eq,Show)+$( derive makeMonoid ''IndependentMeasurements )+-- }}}++data FunctionOfTime α = FunctionOfTime -- {{{+    {   _number_of_samples :: !Word+    ,   _previous_value :: !α+    ,   _previous_time :: !UTCTime+    ,   _first_moment :: !Double+    ,   _second_moment :: !Double+    ,   _minimum_value :: !α+    ,   _maximum_value :: !α+    } deriving (Eq,Show)+$( makeLenses ''FunctionOfTime )+-- }}}++newtype InterpolatedFunctionOfTime α = InterpolatedFunctionOfTime { _interpolated_function_of_time :: FunctionOfTime α } -- {{{+$( makeLenses ''InterpolatedFunctionOfTime )+-- }}}++newtype StepFunctionOfTime α = StepFunctionOfTime { _step_function_of_time :: FunctionOfTime α } -- {{{+$( makeLenses ''StepFunctionOfTime )+-- }}}++-- }}}++{-| Supervisor callbacks provide the means by which the supervisor logic+    communicates to the adapter, usually in order to tell it what it wants to+    say to various workers.+ -}+data SupervisorCallbacks exploration_mode worker_id m = -- {{{+    SupervisorCallbacks+    {   {-| send a progress update request to the given workers -}+        broadcastProgressUpdateToWorkers :: [worker_id] → m ()+    ,   {-| send a workload steal request to the given workers -}+        broadcastWorkloadStealToWorkers :: [worker_id] → m ()+    ,   {-| receive the result of the global progress update that was requested by the controller -}+        receiveCurrentProgress :: ProgressFor exploration_mode → m ()+    ,   {-| send the given workload to the given worker -}+     sendWorkloadToWorker :: Workload → worker_id → m ()+    }+-- }}}++data SupervisorConstants exploration_mode worker_id m = SupervisorConstants -- {{{+    {   callbacks :: !(SupervisorCallbacks exploration_mode worker_id m)+    ,   _current_time :: UTCTime+    ,   _exploration_mode :: ExplorationMode exploration_mode+    }+$( makeLenses ''SupervisorConstants )+-- }}}++data SupervisorState exploration_mode worker_id = -- {{{+    SupervisorState+    {   _waiting_workers_or_available_workloads :: !(Either (Map worker_id (Maybe UTCTime)) (Set Workload))+    ,   _known_workers :: !(Set worker_id)+    ,   _active_workers :: !(Map worker_id Workload)+    ,   _available_workers_for_steal :: !(IntMap (Set worker_id))+    ,   _workers_pending_workload_steal :: !(Set worker_id)+    ,   _workers_pending_progress_update :: !(Set worker_id)+    ,   _current_progress :: !(ProgressFor exploration_mode)+    ,   _debug_mode :: !Bool+    ,   _supervisor_occupation_statistics :: !OccupationStatistics+    ,   _worker_occupation_statistics :: !(Map worker_id OccupationStatistics)+    ,   _retired_worker_occupation_statistics :: !(Map worker_id RetiredOccupationStatistics)+    ,   _worker_wait_time_statistics :: !(InterpolatedFunctionOfTime NominalDiffTime)+    ,   _steal_request_matcher_queue :: !(MultiSet UTCTime)+    ,   _steal_request_failures :: !Int+    ,   _workload_steal_time_statistics :: !IndependentMeasurements+    ,   _waiting_worker_count_statistics :: !(StepFunctionOfTime Int)+    ,   _available_workload_count_statistics :: !(StepFunctionOfTime Int)+    ,   _instantaneous_workload_request_rate :: !ExponentiallyDecayingSum+    ,   _instantaneous_workload_request_rate_statistics :: !(StepFunctionOfTime Float)+    ,   _instantaneous_workload_steal_time :: !ExponentiallyWeightedAverage+    ,   _instantaneous_workload_steal_time_statistics :: !(StepFunctionOfTime Float)+    ,   _time_spent_in_supervisor_monad :: !NominalDiffTime+    ,   _workload_buffer_size :: !Int+    ,   _number_of_calls :: !Int+    }+$( makeLenses ''SupervisorState )+-- }}}++{-| The reason why the supervisor terminated. -}+data SupervisorTerminationReason final_result progress worker_id = -- {{{+    {-| the supervisor aborted before finishing;  included is the current progress at the time it aborted -}+    SupervisorAborted progress+    {-| the supervisor completed exploring the tree;  included is the final result -}+  | SupervisorCompleted final_result+    {-| the supervisor failed to explore the tree;  included is the worker where the failure occured as well as the message and the current progress at the time of failure -}+  | SupervisorFailure progress worker_id String+  deriving (Eq,Show)+-- }}}+{-| A convenient type alias for the 'SupervisorTerminationReason' associated with a given exploration mode. -} +type SupervisorTerminationReasonFor exploration_mode = SupervisorTerminationReason (FinalResultFor exploration_mode) (ProgressFor exploration_mode)++{-| The outcome of running the supervisor. -}+data SupervisorOutcome final_result progress worker_id = -- {{{+    SupervisorOutcome+    {   {-| the reason the supervisor terminated -}+        supervisorTerminationReason :: SupervisorTerminationReason final_result progress worker_id+        {-| the statistics for the run -}+    ,   supervisorRunStatistics :: RunStatistics+        {-| the workers that were present when it finished -}+    ,   supervisorRemainingWorkers :: [worker_id]+    } deriving (Eq,Show)+-- }}}+{-| A convenient type alias for the 'SupervisorOutcome' associated with a given exploration mode. -} +type SupervisorOutcomeFor exploration_mode worker_id = SupervisorOutcome (FinalResultFor exploration_mode) (ProgressFor exploration_mode) worker_id ++type InsideContextMonad exploration_mode worker_id m = -- {{{+    StateT (SupervisorState exploration_mode worker_id) (+        ReaderT (SupervisorConstants exploration_mode worker_id m)+            m+    )+-- }}}+newtype ContextMonad exploration_mode worker_id m α = ContextMonad -- {{{+    { unwrapContextMonad :: InsideContextMonad exploration_mode worker_id m α+    } deriving (Applicative,Functor,Monad,MonadIO)+-- }}}++type InsideAbortMonad exploration_mode worker_id m = -- {{{+    AbortT+        (SupervisorOutcomeFor exploration_mode worker_id)+        (ContextMonad exploration_mode worker_id m)+-- }}}+newtype AbortMonad exploration_mode worker_id m α = AbortMonad -- {{{+    { unwrapAbortMonad :: InsideAbortMonad exploration_mode worker_id m α+    } deriving (Applicative,Functor,Monad,MonadIO)+-- }}}++-- }}}++-- Contraints {{{+type SupervisorReaderConstraint exploration_mode worker_id m m' = MonadReader (SupervisorConstants exploration_mode worker_id m) m'+type SupervisorStateConstraint exploration_mode worker_id m' = MonadState (SupervisorState exploration_mode worker_id) m'++{-| This is the constraint placed on the monad in which the supervisor is running. -}+type SupervisorMonadConstraint m = (Functor m, MonadIO m)+{-| This is the constraint placed on the types that can be used as worker ids. -}+type SupervisorWorkerIdConstraint worker_id = (Eq worker_id, Ord worker_id, Show worker_id, Typeable worker_id)+{-| This is just a sum of 'SupervisorMonadConstraint' and the 'SupervisorWorkerIdConstraint'. -}+type SupervisorFullConstraint worker_id m = (SupervisorWorkerIdConstraint worker_id,SupervisorMonadConstraint m)+-- }}}++-- Classes {{{+class SpecializationOfFunctionOfTime f α where -- {{{+    zoomFunctionOfTimeWithInterpolator ::+        Monad m ⇒+        ((α → α → α) → StateT (FunctionOfTime α) m β) →+        StateT (f α) m β+-- }}}+-- }}}++-- Instances {{{++type instance Zoomed (AbortMonad exploration_mode worker_id m) = Zoomed (InsideAbortMonad exploration_mode worker_id m)++type instance Zoomed (ContextMonad exploration_mode worker_id m) = Zoomed (InsideContextMonad exploration_mode worker_id m)++instance Monad m ⇒ MonadReader (SupervisorConstants exploration_mode worker_id m) (AbortMonad exploration_mode worker_id m) where -- {{{+    ask = AbortMonad ask+    local f = AbortMonad . local f . unwrapAbortMonad+-- }}}++instance Monad m ⇒ MonadReader (SupervisorConstants exploration_mode worker_id m) (ContextMonad exploration_mode worker_id m) where -- {{{+    ask = ContextMonad ask+    local f = ContextMonad . local f . unwrapContextMonad+-- }}}++instance Monad m ⇒ MonadState (SupervisorState exploration_mode worker_id) (AbortMonad exploration_mode worker_id m) where -- {{{+    get = AbortMonad get+    put = AbortMonad . put+-- }}}++instance Monad m ⇒ MonadState (SupervisorState exploration_mode worker_id) (ContextMonad exploration_mode worker_id m) where -- {{{+    get = ContextMonad get+    put = ContextMonad . put+-- }}}++instance Monoid RetiredOccupationStatistics where -- {{{+    mempty = RetiredOccupationStatistics 0 0+    mappend x y = x & (occupied_time +~ y^.occupied_time) & (total_time +~ y^.total_time)+-- }}}++instance StatMonoid IndependentMeasurements NominalDiffTime where -- {{{+    pappend t =+        IndependentMeasurements+            <$> (pappend t' . timeDataMin)+            <*> (pappend t' . timeDataMax)+            <*> (pappend t' . timeDataVariance)+      where t' = realToFrac t :: Double+-- }}}++instance CalcCount IndependentMeasurements where -- {{{+    calcCount = calcCount . timeDataVariance+-- }}}++instance CalcMean IndependentMeasurements where -- {{{+    calcMean = calcMean . timeDataVariance+-- }}}++instance CalcVariance IndependentMeasurements where -- {{{+    calcVariance = calcVariance . timeDataVariance+    calcVarianceUnbiased = calcVarianceUnbiased . timeDataVariance+-- }}}++instance Fractional α ⇒ SpecializationOfFunctionOfTime InterpolatedFunctionOfTime α where -- {{{+    zoomFunctionOfTimeWithInterpolator constructAction = zoom interpolated_function_of_time (constructAction $ ((/2) .* (+)))+-- }}}++instance SpecializationOfFunctionOfTime StepFunctionOfTime α where -- {{{+    zoomFunctionOfTimeWithInterpolator constructAction = zoom step_function_of_time (constructAction . curry $ fst)+-- }}}++-- }}}++-- Functions {{{++abortSupervisor :: SupervisorFullConstraint worker_id m ⇒ AbortMonad exploration_mode worker_id m α -- {{{+abortSupervisor = use current_progress >>= abortSupervisorWithReason . SupervisorAborted+-- }}}++abortSupervisorWithReason ::  -- {{{+    SupervisorFullConstraint worker_id m ⇒+    SupervisorTerminationReasonFor exploration_mode worker_id →+    AbortMonad exploration_mode worker_id m α+abortSupervisorWithReason reason = AbortMonad $+    (SupervisorOutcome+        <$> (return reason)+        <*>  getCurrentStatistics+        <*> (Set.toList <$> use known_workers)+    ) >>= abort+-- }}}++addPointToExponentiallyDecayingSum :: UTCTime → ExponentiallyDecayingSum → ExponentiallyDecayingSum -- {{{+addPointToExponentiallyDecayingSum current_time = execState $ do+    previous_time ← last_decaying_sum_timestamp <<.= current_time+    decaying_sum_value %= (+ 1) . (* computeExponentialDecayCoefficient previous_time current_time)+-- }}}++addPointToExponentiallyWeightedAverage :: Float → UTCTime → ExponentiallyWeightedAverage → ExponentiallyWeightedAverage -- {{{+addPointToExponentiallyWeightedAverage current_value current_time = execState $ do+    previous_time ← last_average_timestamp <<.= current_time+    let old_value_weight = exp . realToFrac $ (previous_time `diffUTCTime` current_time)+        new_value_weight = 1 - old_value_weight+    current_average_value %= (+ new_value_weight * current_value) . (* old_value_weight)+-- }}}++addWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+addWorker worker_id = postValidate ("addWorker " ++ show worker_id) $ do+    infoM $ "Adding worker " ++ show worker_id+    validateWorkerNotKnown "adding worker" worker_id+    known_workers %= Set.insert worker_id+    start_time ← view current_time+    worker_occupation_statistics %= Map.insert worker_id (OccupationStatistics start_time start_time 0 False)+    tryToObtainWorkloadFor True worker_id+-- }}}++beginWorkerOccupied :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+beginWorkerOccupied = flip changeWorkerOccupiedStatus True+-- }}}++changeOccupiedStatus :: -- {{{+    ( Monad m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒+    m' OccupationStatistics →+    (OccupationStatistics → m' ()) →+    Bool →+    m' ()+changeOccupiedStatus getOccupation putOccupation new_occupied_status = do+    old_occupation ← getOccupation+    unless (old_occupation^.is_currently_occupied == new_occupied_status) $+        (flip execStateT old_occupation $ do+            current_time ← view current_time+            is_currently_occupied .= new_occupied_status+            last_time ← last_occupied_change_time <<.= current_time+            unless new_occupied_status $ total_occupied_time += (current_time `diffUTCTime` last_time)+        ) >>= putOccupation+-- }}}++changeSupervisorOccupiedStatus :: SupervisorMonadConstraint m ⇒ Bool → ContextMonad exploration_mode worker_id m () -- {{{+changeSupervisorOccupiedStatus =+    changeOccupiedStatus+        (use supervisor_occupation_statistics)+        (supervisor_occupation_statistics .=)+-- }}}++changeWorkerOccupiedStatus :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    Bool →+    ContextMonad exploration_mode worker_id m ()+changeWorkerOccupiedStatus worker_id =+    changeOccupiedStatus+        (fromJust . Map.lookup worker_id <$> use worker_occupation_statistics)+        ((worker_occupation_statistics %=) . Map.insert worker_id)+-- }}}++checkWhetherMoreStealsAreNeeded :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ContextMonad exploration_mode worker_id m ()+checkWhetherMoreStealsAreNeeded = do+    (number_of_waiting_workers,number_of_available_workloads) ←+        either (Map.size &&& const 0) (const 0 &&& Set.size)+        <$>+        use waiting_workers_or_available_workloads+    number_of_pending_workload_steals ← Set.size <$> use workers_pending_workload_steal+    available_workers ← use available_workers_for_steal+    when (number_of_pending_workload_steals == 0+       && number_of_waiting_workers > 0+       && IntMap.null available_workers+      ) $ throw OutOfSourcesForNewWorkloads+    workload_buffer_size ← use workload_buffer_size+    let number_of_needed_steals =+         (0 + workload_buffer_size + number_of_waiting_workers+            - number_of_available_workloads - number_of_pending_workload_steals+         ) `max` 0+    debugM $+        printf "needed steals (%i) = buffer size (%i) + waiting workers (%i) - available workloads (%i) - pending steals (%i)"+            number_of_needed_steals+            workload_buffer_size+            number_of_waiting_workers+            number_of_available_workloads+            number_of_pending_workload_steals+    when (number_of_needed_steals > 0) $ do+        let findWorkers accum 0 available_workers = (accum,available_workers)+            findWorkers accum n available_workers =+                case IntMap.minViewWithKey available_workers of+                    Nothing → (accum,IntMap.empty)+                    Just ((depth,workers),deeper_workers) →+                        go accum n workers+                      where+                        go accum 0 workers =+                            (accum+                            ,if Set.null workers+                                then deeper_workers+                                else IntMap.insert depth workers deeper_workers+                            )+                        go accum n workers =+                            case Set.minView workers of+                                Nothing → findWorkers accum n deeper_workers+                                Just (worker_id,rest_workers) → go (worker_id:accum) (n-1) rest_workers+        workers_to_steal_from ← available_workers_for_steal %%= findWorkers [] number_of_needed_steals+        let number_of_workers_to_steal_from = length workers_to_steal_from+        number_of_additional_requests ← steal_request_failures %%=+            \number_of_steal_request_failures →+                if number_of_steal_request_failures >= number_of_workers_to_steal_from+                    then (0,number_of_steal_request_failures-number_of_workers_to_steal_from)+                    else (number_of_workers_to_steal_from-number_of_steal_request_failures,0)+        current_time ← view current_time+        steal_request_matcher_queue %= (MultiSet.insertMany current_time number_of_additional_requests)+        workers_pending_workload_steal %= (Set.union . Set.fromList) workers_to_steal_from+        unless (null workers_to_steal_from) $ do+            infoM $ "Sending workload steal requests to " ++ show workers_to_steal_from+            asks (callbacks >>> broadcastWorkloadStealToWorkers) >>= liftUserToContext . ($ workers_to_steal_from)+-- }}}++clearPendingProgressUpdate :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+clearPendingProgressUpdate worker_id =+    Set.member worker_id <$> use workers_pending_progress_update >>= flip when+    -- Note, the conditional above is needed to prevent a "misfire" where+    -- we think that we have just completed a progress update even though+    -- none was started.+    (do workers_pending_progress_update %= Set.delete worker_id+        no_progress_updates_are_pending ← Set.null <$> use workers_pending_progress_update+        when no_progress_updates_are_pending sendCurrentProgressToUser+    )+-- }}}++computeExponentialDecayCoefficient :: UTCTime → UTCTime → Float -- {{{+computeExponentialDecayCoefficient = (exp . realToFrac) .* diffUTCTime+-- }}}++computeInstantaneousRateFromDecayingSum :: -- {{{+    ( Functor m'+    , SupervisorMonadConstraint m+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒+    ExponentiallyDecayingSum →+    m' Float+computeInstantaneousRateFromDecayingSum expsum = do+    current_time ← view current_time+    flip runReaderT expsum $ do+        previous_time ← view last_decaying_sum_timestamp+        (* computeExponentialDecayCoefficient previous_time current_time) <$> view decaying_sum_value+-- }}}++deactivateWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Bool →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+deactivateWorker reenqueue_workload worker_id = do+    pending_steal ← workers_pending_workload_steal %%= (Set.member worker_id &&& Set.delete worker_id)+    when pending_steal $ steal_request_failures += 1+    dequeueWorkerForSteal worker_id+    if reenqueue_workload+        then active_workers <<%= Map.delete worker_id+              >>=+                enqueueWorkload+                .+                fromMaybe (error $ "Attempt to deactivate worker " ++ show worker_id ++ " which was not listed as active.")+                .+                Map.lookup worker_id+        else active_workers %= Map.delete worker_id+    clearPendingProgressUpdate worker_id+    checkWhetherMoreStealsAreNeeded+-- }}}++dequeueWorkerForSteal :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+dequeueWorkerForSteal worker_id =+    getWorkerDepth worker_id >>= \depth →+        available_workers_for_steal %=+            IntMap.update+                (\queue → let new_queue = Set.delete worker_id queue+                          in if Set.null new_queue then Nothing else Just new_queue+                )+                depth+-- }}}++endWorkerOccupied :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+endWorkerOccupied = flip changeWorkerOccupiedStatus False+-- }}}++enqueueWorkerForSteal :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+enqueueWorkerForSteal worker_id =+    getWorkerDepth worker_id >>= \depth →+        available_workers_for_steal %=+            IntMap.alter+                (Just . maybe (Set.singleton worker_id) (Set.insert worker_id))+                depth+-- }}}++enqueueWorkload :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Workload →+    ContextMonad exploration_mode worker_id m ()+enqueueWorkload workload =+    use waiting_workers_or_available_workloads+    >>=+    \x → case x of+        Left waiting_workers →+            case Map.minViewWithKey waiting_workers of+                Just ((free_worker_id,maybe_time_started_waiting),remaining_workers) → do+                    waiting_workers_or_available_workloads .= Left remaining_workers+                    maybe (return ())+                          (timePassedSince >=> updateFunctionOfTimeUsingLens worker_wait_time_statistics)+                          maybe_time_started_waiting+                    sendWorkloadTo workload free_worker_id+                    updateFunctionOfTimeUsingLens waiting_worker_count_statistics (Map.size remaining_workers)+                Nothing → do+                    waiting_workers_or_available_workloads .= Right (Set.singleton workload)+                    updateFunctionOfTimeUsingLens available_workload_count_statistics 1+        Right available_workloads → do+            waiting_workers_or_available_workloads .= Right (Set.insert workload available_workloads)+            updateFunctionOfTimeUsingLens available_workload_count_statistics (Set.size available_workloads + 1)+    >>+    checkWhetherMoreStealsAreNeeded+-- }}}++extractFunctionOfTimeStatistics :: -- {{{+    ( Ord α+    , Real α+    , SupervisorMonadConstraint m+    , SupervisorMonadConstraint m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    , SpecializationOfFunctionOfTime f α+    ) ⇒+    UTCTime →+    m' (f α) →+    m' (FunctionOfTimeStatistics α)+extractFunctionOfTimeStatistics start_time getWeightedStatistics = do+    getWeightedStatistics >>= (evalStateT $ do+        zoomFunctionOfTime $ do+            total_weight ← realToFrac . (`diffUTCTime` start_time) <$> use previous_time+            timeCount ← use number_of_samples+            timeAverage ← (/total_weight) <$> use first_moment+            timeStdDev ← sqrt . (subtract $ timeAverage*timeAverage) . (/total_weight) <$> use second_moment+            timeMin ← use minimum_value+            timeMax ← use maximum_value+            return $ FunctionOfTimeStatistics{..}+     )+-- }}}++extractFunctionOfTimeStatisticsWithFinalPoint :: -- {{{+    ( Ord α+    , Real α+    , SupervisorMonadConstraint m+    , SupervisorMonadConstraint m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    , SpecializationOfFunctionOfTime f α+    ) ⇒+    UTCTime →+    m' α →+    m' (f α) →+    m' (FunctionOfTimeStatistics α)+extractFunctionOfTimeStatisticsWithFinalPoint start_time getFinalValue getWeightedStatistics = do+    end_time ← view current_time+    let total_weight = realToFrac (end_time `diffUTCTime` start_time)+    final_value ← getFinalValue+    getWeightedStatistics >>= (evalStateT $ do+        updateFunctionOfTime final_value end_time+        zoomFunctionOfTime $ do+            timeCount ← use number_of_samples+            timeAverage ← (/total_weight) <$> use first_moment+            timeStdDev ← sqrt . (\x → x-timeAverage*timeAverage) . (/total_weight) <$> use second_moment+            timeMin ← min final_value <$> use minimum_value+            timeMax ← max final_value <$> use maximum_value+            return $ FunctionOfTimeStatistics{..}+     )+-- }}}++extractIndependentMeasurementsStatistics :: IndependentMeasurements → IndependentMeasurementsStatistics -- {{{+extractIndependentMeasurementsStatistics =+    IndependentMeasurementsStatistics+        <$>  calcCount+        <*>  calcMean+        <*>  calcStddev+        <*> (calcMin . timeDataMin)+        <*> (calcMax . timeDataMax)+-- }}}++finishWithResult :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    FinalResultFor exploration_mode →+    InsideAbortMonad exploration_mode worker_id m α+finishWithResult final_value =+    SupervisorOutcome+        <$> (return $ SupervisorCompleted final_value)+        <*> (lift getCurrentStatistics)+        <*> (Set.toList <$> use known_workers)+     >>= abort+-- }}}++getCurrentCheckpoint :: -- {{{+    ( SupervisorMonadConstraint m'+    , SupervisorStateConstraint exploration_mode worker_id m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒ m' Checkpoint+getCurrentCheckpoint =+    liftM2 checkpointFromIntermediateProgress+        (view exploration_mode)+        (use current_progress)+-- }}}++getCurrentProgress :: SupervisorMonadConstraint m ⇒ ContextMonad exploration_mode worker_id m (ProgressFor exploration_mode) -- {{{+getCurrentProgress = use current_progress+-- }}}++getCurrentStatistics :: -- {{{+    ( SupervisorFullConstraint worker_id m+    , SupervisorMonadConstraint m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    , SupervisorStateConstraint exploration_mode worker_id m'+    ) ⇒+    m' RunStatistics+getCurrentStatistics = do+    runEndTime ← view current_time+    runStartTime ← use (supervisor_occupation_statistics . start_time)+    let runWallTime = runEndTime `diffUTCTime` runStartTime+    runSupervisorOccupation ←+        use supervisor_occupation_statistics+        >>=+        retireOccupationStatistics+        >>=+        return . getOccupationFraction+    runSupervisorMonadOccupation ←+        realToFrac+        .+        (/runWallTime)+        <$>+        use time_spent_in_supervisor_monad+    runNumberOfCalls ← use number_of_calls+    let runAverageTimePerCall = runSupervisorMonadOccupation / fromIntegral runNumberOfCalls+    runWorkerOccupation ←+        getOccupationFraction . mconcat . Map.elems+        <$>+        liftM2 (Map.unionWith (<>))+            (use retired_worker_occupation_statistics)+            (use worker_occupation_statistics >>= retireManyOccupationStatistics)+    runWorkerWaitTimes ←+        extractFunctionOfTimeStatistics+            runStartTime+            (use worker_wait_time_statistics)+    runStealWaitTimes ← extractIndependentMeasurementsStatistics <$> use workload_steal_time_statistics+    runWaitingWorkerStatistics ←+        extractFunctionOfTimeStatisticsWithFinalPoint+            runStartTime+            (either Map.size (const 0) <$> use waiting_workers_or_available_workloads)+            (use waiting_worker_count_statistics)+    runAvailableWorkloadStatistics ←+        extractFunctionOfTimeStatisticsWithFinalPoint+            runStartTime+            (either (const 0) Set.size <$> use waiting_workers_or_available_workloads)+            (use available_workload_count_statistics)+    runInstantaneousWorkloadRequestRateStatistics ←+        extractFunctionOfTimeStatisticsWithFinalPoint+            runStartTime+            (use instantaneous_workload_request_rate >>= computeInstantaneousRateFromDecayingSum)+            (use instantaneous_workload_request_rate_statistics)+    runInstantaneousWorkloadStealTimeStatistics ←+        extractFunctionOfTimeStatisticsWithFinalPoint+            runStartTime+            (use $ instantaneous_workload_steal_time . current_average_value)+            (use instantaneous_workload_steal_time_statistics)+    return RunStatistics{..}+-- }}}++getNumberOfWorkers :: SupervisorMonadConstraint m ⇒ ContextMonad exploration_mode worker_id m Int -- {{{+getNumberOfWorkers = liftM Set.size . use $ known_workers+-- }}}++getOccupationFraction :: RetiredOccupationStatistics → Float -- {{{+getOccupationFraction = realToFrac . liftA2 (/) (^.occupied_time) (^.total_time)+-- }}}++getWorkerDepth :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m Int+getWorkerDepth worker_id =+    maybe+        (error $ "Attempted to use the depth of inactive worker " ++ show worker_id ++ ".")+        workloadDepth+    .+    Map.lookup worker_id+    <$>+    use active_workers+-- }}}++initialFunctionForStartingTimeAndValue :: Num α ⇒ UTCTime → α → FunctionOfTime α -- {{{+initialFunctionForStartingTimeAndValue starting_time starting_value =+    FunctionOfTime+        0+        starting_value+        starting_time+        0+        0+        (fromIntegral (maxBound :: Int))+        (fromIntegral (minBound :: Int))+-- }}}++initialInterpolatedFunctionForStartingTime :: Num α ⇒ UTCTime → InterpolatedFunctionOfTime α -- {{{+initialInterpolatedFunctionForStartingTime = flip initialInterpolatedFunctionForStartingTimeAndValue 0+-- }}}++initialInterpolatedFunctionForStartingTimeAndValue :: Num α ⇒ UTCTime → α → InterpolatedFunctionOfTime α -- {{{+initialInterpolatedFunctionForStartingTimeAndValue = InterpolatedFunctionOfTime .* initialFunctionForStartingTimeAndValue+-- }}}++initialStepFunctionForStartingTime :: Num α ⇒ UTCTime → StepFunctionOfTime α -- {{{+initialStepFunctionForStartingTime = flip initialStepFunctionForStartingTimeAndValue 0+-- }}}++initialStepFunctionForStartingTimeAndValue :: Num α ⇒ UTCTime → α → StepFunctionOfTime α -- {{{+initialStepFunctionForStartingTimeAndValue = StepFunctionOfTime .* initialFunctionForStartingTimeAndValue+-- }}}++liftContextToAbort :: Monad m ⇒ ContextMonad exploration_mode worker_id m α → AbortMonad exploration_mode worker_id m α -- {{{+liftContextToAbort = AbortMonad . lift+-- }}}++liftUserToAbort :: Monad m ⇒ m α → AbortMonad exploration_mode worker_id m α -- {{{+liftUserToAbort = liftContextToAbort . liftUserToContext+-- }}}++liftUserToContext :: Monad m ⇒ m α → ContextMonad exploration_mode worker_id m α -- {{{+liftUserToContext = ContextMonad . lift . lift+-- }}}++localWithinAbort :: -- {{{+    MonadReader e m ⇒+    (e → e) →+    AbortMonad exploration_mode worker_id m α →+    AbortMonad exploration_mode worker_id m α+localWithinAbort f = AbortMonad . AbortT . localWithinContext f . unwrapAbortT . unwrapAbortMonad+-- }}}++localWithinContext :: -- {{{+    MonadReader e m ⇒+    (e → e) →+    ContextMonad exploration_mode worker_id m α →+    ContextMonad exploration_mode worker_id m α+localWithinContext f m = do+    actions ← ask+    old_state ← get+    (result,new_state) ←+        ContextMonad+        .+        lift+        .+        lift+        .+        local f+        .+        flip runReaderT actions+        .+        flip runStateT old_state+        .+        unwrapContextMonad+        $+        m+    put new_state+    return result+-- }}}++performGlobalProgressUpdate :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ContextMonad exploration_mode worker_id m ()+performGlobalProgressUpdate = postValidate "performGlobalProgressUpdate" $ do+    infoM $ "Performing global progress update."+    active_worker_ids ← Map.keysSet <$> use active_workers+    if (Set.null active_worker_ids)+        then sendCurrentProgressToUser+        else do+            workers_pending_progress_update .= active_worker_ids+            asks (callbacks >>> broadcastProgressUpdateToWorkers) >>= liftUserToContext . ($ Set.toList active_worker_ids)+-- }}}++postValidate :: -- {{{+    ( SupervisorMonadConstraint m'+    , SupervisorFullConstraint worker_id m+    , SupervisorStateConstraint exploration_mode worker_id m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒+    String →+    m' α →+    m' α+postValidate label action = action >>= \result →+  (use debug_mode >>= flip when (do+    checkpoint ← getCurrentCheckpoint+    debugM $ " === BEGIN VALIDATE === " ++ label+    use known_workers >>= debugM . ("Known workers is now " ++) . show+    use active_workers >>= debugM . ("Active workers is now " ++) . show+    use waiting_workers_or_available_workloads >>= debugM . ("Waiting/Available queue is now " ++) . show+    debugM . ("Current checkpoint is now " ++) . show $ checkpoint+    workers_and_workloads ←+        liftM2 (++)+            (map (Nothing,) . Set.toList . either (const (Set.empty)) id <$> use waiting_workers_or_available_workloads)+            (map (first Just) . Map.assocs <$> use active_workers)+    let go [] _ = return ()+        go ((maybe_worker_id,Workload initial_path _):rest_workloads) known_prefixes =+            case Map.lookup initial_path_as_list known_prefixes of+                Nothing → go rest_workloads . mappend known_prefixes . Map.fromList . map (,(maybe_worker_id,initial_path)) . inits $ initial_path_as_list+                Just (maybe_other_worker_id,other_initial_path) →+                    throw $ ConflictingWorkloads maybe_worker_id initial_path maybe_other_worker_id other_initial_path+          where initial_path_as_list = Fold.toList initial_path+    go workers_and_workloads Map.empty+    let total_workspace =+            mappend checkpoint+            .+            mconcat+            .+            map (flip checkpointFromInitialPath Explored . workloadPath . snd)+            $+            workers_and_workloads+    unless (total_workspace == Explored) $ throw $ IncompleteWorkspace total_workspace+    when (checkpoint == Explored) $+        if null workers_and_workloads+            then throw $ SpaceFullyExploredButSearchNotTerminated+            else throw $ SpaceFullyExploredButWorkloadsRemain workers_and_workloads+    debugM $ " === END VALIDATE === " ++ label+  )) >> return result+-- }}}++receiveProgressUpdate :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ProgressUpdateFor exploration_mode →+    AbortMonad exploration_mode worker_id m ()+receiveProgressUpdate worker_id (ProgressUpdate progress_update remaining_workload) = AbortMonad . postValidate ("receiveProgressUpdate " ++ show worker_id ++ " ...") $ do+    infoM $ "Received progress update from " ++ show worker_id+    lift $ validateWorkerKnownAndActive "receiving progress update" worker_id+    _ ← updateCurrentProgress progress_update+    lift $ do+        is_pending_workload_steal ← Set.member worker_id <$> use workers_pending_workload_steal+        unless is_pending_workload_steal $ dequeueWorkerForSteal worker_id+        active_workers %= Map.insert worker_id remaining_workload+        unless is_pending_workload_steal $ enqueueWorkerForSteal worker_id+        clearPendingProgressUpdate worker_id+-- }}}++receiveStolenWorkload :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    Maybe (StolenWorkloadFor exploration_mode) →+    AbortMonad exploration_mode worker_id m ()+receiveStolenWorkload worker_id maybe_stolen_workload = AbortMonad . postValidate ("receiveStolenWorkload " ++ show worker_id ++ " ...") $ do+    infoM $ "Received stolen workload from " ++ show worker_id+    lift $ validateWorkerKnownAndActive "receiving stolen workload" worker_id+    workers_pending_workload_steal %= Set.delete worker_id+    case maybe_stolen_workload of+        Nothing → steal_request_failures += 1+        Just (StolenWorkload (ProgressUpdate progress_update remaining_workload) workload) → do+            lift $+                (steal_request_matcher_queue %%= fromMaybe (error "Unable to find a request matching this steal!") . MultiSet.minView)+                  >>= (timePassedSince >=> liftA2 (>>) ((workload_steal_time_statistics %=) . pappend) updateInstataneousWorkloadStealTime)+            _ ← updateCurrentProgress progress_update+            lift $ do+                active_workers %= Map.insert worker_id remaining_workload+                enqueueWorkload workload+    lift $ do+        enqueueWorkerForSteal worker_id+        checkWhetherMoreStealsAreNeeded+-- }}}++receiveWorkerFinishedWithRemovalFlag :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Bool →+    worker_id →+    WorkerFinishedProgressFor exploration_mode →+    AbortMonad exploration_mode worker_id m ()+receiveWorkerFinishedWithRemovalFlag remove_worker worker_id final_progress = AbortMonad . postValidate ("receiveWorkerFinished " ++ show worker_id) $ do+    infoM $ if remove_worker+        then "Worker " ++ show worker_id ++ " finished and removed."+        else "Worker " ++ show worker_id ++ " finished."+    lift $ validateWorkerKnownAndActive "the worker was declared finished" worker_id+    when remove_worker . lift $ retireWorker worker_id+    exploration_mode ← view exploration_mode+    (checkpoint,final_value) ←+        case exploration_mode of+            AllMode →+                (progressCheckpoint &&& progressResult)+                <$>+                updateCurrentProgress final_progress+            FirstMode → do+                let Progress{..} = final_progress+                checkpoint ← updateCurrentProgress progressCheckpoint+                case progressResult of+                    Nothing → return (checkpoint,Nothing)+                    Just solution → finishWithResult . Just $ Progress checkpoint solution+            FoundModeUsingPull _ →+                (progressCheckpoint &&& Left . progressResult)+                <$>+                updateCurrentProgress final_progress+            FoundModeUsingPush _ → do+                (progressCheckpoint &&& Left . progressResult)+                <$>+                updateCurrentProgress final_progress+    case checkpoint of+        Explored → do+            active_worker_ids ← Map.keys . Map.delete worker_id <$> use active_workers+            unless (null active_worker_ids) . throw $+                ActiveWorkersRemainedAfterSpaceFullyExplored active_worker_ids+            finishWithResult final_value+        _ → lift $ do+                deactivateWorker False worker_id+                unless remove_worker $ do+                    endWorkerOccupied worker_id+                    tryToObtainWorkloadFor False worker_id+-- }}}++retireManyOccupationStatistics :: -- {{{+    ( Functor f+    , SupervisorMonadConstraint m+    , Monad m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒+    f OccupationStatistics →+    m' (f RetiredOccupationStatistics)+retireManyOccupationStatistics occupied_statistics =+    view current_time >>= \current_time → return $+    fmap (\o → mempty+        & occupied_time .~ (o^.total_occupied_time + if o^.is_currently_occupied then current_time `diffUTCTime` (o^.last_occupied_change_time) else 0)+        & total_time .~ (current_time `diffUTCTime` (o^.start_time))+    ) occupied_statistics+-- }}}++retireOccupationStatistics :: -- {{{+    ( SupervisorMonadConstraint m+    , Monad m'+    , SupervisorReaderConstraint exploration_mode worker_id m m'+    ) ⇒+    OccupationStatistics →+    m' RetiredOccupationStatistics+retireOccupationStatistics = liftM head . retireManyOccupationStatistics . (:[])+-- }}}++removeWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+removeWorker worker_id = postValidate ("removeWorker " ++ show worker_id) $ do+    infoM $ "Removing worker " ++ show worker_id+    validateWorkerKnown "removing the worker" worker_id+    retireAndDeactivateWorker worker_id+-- }}}++removeWorkerIfPresent :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+removeWorkerIfPresent worker_id = postValidate ("removeWorker " ++ show worker_id) $ do+    whenM (Set.member worker_id <$> use known_workers) $ do+        infoM $ "Removing worker " ++ show worker_id+        retireAndDeactivateWorker worker_id+-- }}}++retireWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+retireWorker worker_id = do+    known_workers %= Set.delete worker_id+    retired_occupation_statistics ←+        worker_occupation_statistics %%= (fromJust . Map.lookup worker_id &&& Map.delete worker_id)+        >>=+        retireOccupationStatistics+    retired_worker_occupation_statistics %= Map.alter (+        Just . maybe retired_occupation_statistics (<> retired_occupation_statistics)+     ) worker_id+-- }}}++retireAndDeactivateWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    worker_id →+    ContextMonad exploration_mode worker_id m ()+retireAndDeactivateWorker worker_id = do+    retireWorker worker_id+    ifM (isJust . Map.lookup worker_id <$> use active_workers)+        (deactivateWorker True worker_id)+        (waiting_workers_or_available_workloads %%=+            either (pred . Map.size &&& Left . Map.delete worker_id)+                   (error $ "worker " ++ show worker_id ++ " is inactive but was not in the waiting queue")+         >>= updateFunctionOfTimeUsingLens waiting_worker_count_statistics+        )+-- }}}++runSupervisorStartingFrom :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ExplorationMode exploration_mode →+    ProgressFor exploration_mode →+    SupervisorCallbacks exploration_mode worker_id m →+    (∀ α. AbortMonad exploration_mode worker_id m α) →+    m (SupervisorOutcomeFor exploration_mode worker_id)+runSupervisorStartingFrom exploration_mode starting_progress callbacks program = liftIO Clock.getCurrentTime >>= \start_time →+    flip runReaderT (SupervisorConstants callbacks undefined exploration_mode)+    .+    flip evalStateT+        (SupervisorState+            {   _waiting_workers_or_available_workloads =+                    Right . Set.singleton $+                        Workload+                            Seq.empty+                            (checkpointFromIntermediateProgress+                                exploration_mode+                                starting_progress+                            )+            ,   _known_workers = mempty+            ,   _active_workers = mempty+            ,   _available_workers_for_steal = mempty+            ,   _workers_pending_workload_steal = mempty+            ,   _workers_pending_progress_update = mempty+            ,   _current_progress = starting_progress+            ,   _debug_mode = False+            ,   _supervisor_occupation_statistics = OccupationStatistics+                {   _start_time = start_time+                ,   _last_occupied_change_time = start_time+                ,   _total_occupied_time = 0+                ,   _is_currently_occupied = False+                }+            ,   _worker_occupation_statistics = mempty+            ,   _retired_worker_occupation_statistics = mempty+            ,   _worker_wait_time_statistics = initialInterpolatedFunctionForStartingTime start_time+            ,   _steal_request_matcher_queue = mempty+            ,   _steal_request_failures = 0+            ,   _workload_steal_time_statistics = mempty+            ,   _waiting_worker_count_statistics = initialStepFunctionForStartingTime start_time+            ,   _available_workload_count_statistics = initialStepFunctionForStartingTime start_time+            ,   _instantaneous_workload_request_rate = ExponentiallyDecayingSum start_time 0+            ,   _instantaneous_workload_request_rate_statistics = initialStepFunctionForStartingTime start_time+            ,   _instantaneous_workload_steal_time = ExponentiallyWeightedAverage start_time 0+            ,   _instantaneous_workload_steal_time_statistics = initialStepFunctionForStartingTime start_time+            ,   _time_spent_in_supervisor_monad = 0+            ,   _workload_buffer_size = 4+            ,   _number_of_calls = 0+            }+        )+    .+    unwrapContextMonad+    .+    runAbortT+    .+    unwrapAbortMonad+    $+    program+-- }}}++sendCurrentProgressToUser :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ContextMonad exploration_mode worker_id m ()+sendCurrentProgressToUser = do+    callback ← asks (callbacks >>> receiveCurrentProgress)+    current_progress ← use current_progress+    liftUserToContext (callback current_progress)+-- }}}++sendWorkloadTo :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Workload →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+sendWorkloadTo workload worker_id = do+    infoM $ "Sending workload to " ++ show worker_id+    asks (callbacks >>> sendWorkloadToWorker) >>= liftUserToContext . (\f → f workload worker_id)+    isNothing . Map.lookup worker_id <$> use active_workers+        >>= flip unless (throw $ WorkerAlreadyHasWorkload worker_id)+    active_workers %= Map.insert worker_id workload+    beginWorkerOccupied worker_id+    enqueueWorkerForSteal worker_id+    checkWhetherMoreStealsAreNeeded+-- }}}++setSupervisorDebugMode :: SupervisorMonadConstraint m ⇒ Bool → ContextMonad exploration_mode worker_id m () -- {{{+setSupervisorDebugMode = (debug_mode .=)+-- }}}++setWorkloadBufferSize :: SupervisorMonadConstraint m ⇒ Int → ContextMonad exploration_mode worker_id m () -- {{{+setWorkloadBufferSize = (workload_buffer_size .=)+-- }}}++timePassedSince :: -- {{{+    ( Functor m'+    , SupervisorMonadConstraint m+    , SupervisorReaderConstraint exploration_mode worker_id m  m'+    ) ⇒+    UTCTime →+    m' NominalDiffTime+timePassedSince = (<$> view current_time) . flip diffUTCTime+-- }}}++tryGetWaitingWorker :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ContextMonad exploration_mode worker_id m (Maybe worker_id)+tryGetWaitingWorker =+    either (fmap (fst . fst) . Map.minViewWithKey) (const Nothing)+    <$>+    use waiting_workers_or_available_workloads+-- }}}++tryToObtainWorkloadFor :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    Bool →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+tryToObtainWorkloadFor is_new_worker worker_id =+    unless is_new_worker updateInstataneousWorkloadRequestRate+    >>+    use waiting_workers_or_available_workloads+    >>=+    \x → case x of+        Left waiting_workers → do+            maybe_time_started_waiting ← getMaybeTimeStartedWorking+            waiting_workers_or_available_workloads .= Left (Map.insert worker_id maybe_time_started_waiting waiting_workers)+            updateFunctionOfTimeUsingLens waiting_worker_count_statistics (Map.size waiting_workers + 1)+        Right available_workers →+            case Set.minView available_workers of+                Nothing → do+                    maybe_time_started_waiting ← getMaybeTimeStartedWorking+                    waiting_workers_or_available_workloads .= Left (Map.singleton worker_id maybe_time_started_waiting)+                    updateFunctionOfTimeUsingLens waiting_worker_count_statistics 1+                Just (workload,remaining_workloads) → do+                    unless is_new_worker $ updateFunctionOfTimeUsingLens worker_wait_time_statistics 0+                    sendWorkloadTo workload worker_id+                    waiting_workers_or_available_workloads .= Right remaining_workloads+                    updateFunctionOfTimeUsingLens available_workload_count_statistics (Set.size remaining_workloads + 1)+    >>+    checkWhetherMoreStealsAreNeeded+  where+    getMaybeTimeStartedWorking+      | is_new_worker = return Nothing+      | otherwise = Just <$> view current_time++-- }}}++updateCurrentProgress :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    ProgressFor exploration_mode →+    InsideAbortMonad exploration_mode worker_id m (ProgressFor exploration_mode)+updateCurrentProgress progress = do+    exploration_mode ← view exploration_mode+    case exploration_mode of+        AllMode → current_progress <%= (<> progress)+        FirstMode → current_progress <%= (<> progress)+        FoundModeUsingPull f → do+            progress@(Progress _ result) ← current_progress <%= (<> progress)+            if f result+                then finishWithResult (Right progress)+                else return progress+        FoundModeUsingPush f → do+            progress@(Progress _ result) ← current_progress <%= (<> progress)+            if f result+                then finishWithResult (Right progress)+                else return progress+-- }}}++updateFunctionOfTime :: -- {{{+    ( MonadIO m+    , Real α+    , SpecializationOfFunctionOfTime f α+    ) ⇒+    α →+    UTCTime →+    StateT (f α) m ()+updateFunctionOfTime value current_time =+  zoomFunctionOfTimeWithInterpolator $ \interpolate → do+    number_of_samples += 1+    last_time ← previous_time <<.= current_time+    last_value ← previous_value <<.= value+    let weight = realToFrac (current_time `diffUTCTime` last_time)+        interpolated_value = realToFrac $ interpolate last_value value+    first_moment += weight*interpolated_value+    second_moment += weight*interpolated_value*interpolated_value+    minimum_value %= min value+    maximum_value %= max value+-- }}}++updateFunctionOfTimeUsingLens :: -- {{{+    ( Real α+    , SupervisorMonadConstraint m+    , SpecializationOfFunctionOfTime f α+    ) ⇒+    Lens' (SupervisorState exploration_mode worker_id) (f α) →+    α →+    ContextMonad exploration_mode worker_id m ()+updateFunctionOfTimeUsingLens field value =+    view current_time >>= ContextMonad . void . zoom field . updateFunctionOfTime value+-- }}}++updateInstataneousWorkloadRequestRate :: SupervisorMonadConstraint m ⇒ ContextMonad exploration_mode worker_id m () -- {{{+updateInstataneousWorkloadRequestRate = do+    current_time ← view current_time+    previous_value ← instantaneous_workload_request_rate %%= ((^.decaying_sum_value) &&& addPointToExponentiallyDecayingSum current_time)+    current_value ← use (instantaneous_workload_request_rate . decaying_sum_value)+    updateFunctionOfTimeUsingLens instantaneous_workload_request_rate_statistics ((current_value + previous_value) / 2)+-- }}}++updateInstataneousWorkloadStealTime :: SupervisorMonadConstraint m ⇒ NominalDiffTime → ContextMonad exploration_mode worker_id m () -- {{{+updateInstataneousWorkloadStealTime (realToFrac → current_value) = do+    current_time ← view current_time+    previous_value ← instantaneous_workload_steal_time %%= ((^.current_average_value) &&& addPointToExponentiallyWeightedAverage current_value current_time)+    current_value ← use (instantaneous_workload_steal_time . current_average_value)+    updateFunctionOfTimeUsingLens instantaneous_workload_steal_time_statistics ((current_value + previous_value) / 2)+-- }}}++validateWorkerKnown :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    String →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+validateWorkerKnown action worker_id =+    Set.notMember worker_id <$> (use known_workers)+        >>= flip when (throw $ WorkerNotKnown action worker_id)+-- }}}++validateWorkerKnownAndActive :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    String →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+validateWorkerKnownAndActive action worker_id = do+    validateWorkerKnown action worker_id+    Set.notMember worker_id <$> (use known_workers)+        >>= flip when (throw $ WorkerNotActive action worker_id)+-- }}}++validateWorkerNotKnown :: -- {{{+    ( SupervisorMonadConstraint m+    , SupervisorWorkerIdConstraint worker_id+    ) ⇒+    String →+    worker_id →+    ContextMonad exploration_mode worker_id m ()+validateWorkerNotKnown action worker_id = do+    Set.member worker_id <$> (use known_workers)+        >>= flip when (throw $ WorkerAlreadyKnown action worker_id)+-- }}}++zoomFunctionOfTime :: -- {{{+    ( SpecializationOfFunctionOfTime f α+    , Monad m+    ) ⇒+    StateT (FunctionOfTime α) m β →+    StateT (f α) m β+zoomFunctionOfTime m = zoomFunctionOfTimeWithInterpolator (const m)+-- }}}++-- }}}
+ sources/LogicGrowsOnTrees/Parallel/Common/Worker.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| The 'Worker' module contains the workhorse code of the parallelization+    infrastructure in the form of the 'forkWorkerThread' function, which+    explores a tree step by step while continuously polling for requests; for+    more details see 'forkWorkerThread'.+ -}+module LogicGrowsOnTrees.Parallel.Common.Worker+    (+    -- * Types+    -- ** Worker interaction+      ProgressUpdate(..)+    , ProgressUpdateFor+    , StolenWorkload(..)+    , StolenWorkloadFor+    , WorkerRequestQueue+    , WorkerRequestQueueFor+    , WorkerEnvironment(..)+    , WorkerEnvironmentFor+    , WorkerTerminationReason(..)+    , WorkerTerminationReasonFor+    , WorkerPushActionFor+    -- * Functions+    , forkWorkerThread+    , sendAbortRequest+    , sendProgressUpdateRequest+    , sendWorkloadStealRequest+    , exploreTreeGeneric+    ) where++import Prelude hiding (catch)++import Control.Arrow ((&&&))+import Control.Concurrent (forkIO,ThreadId,yield)+import Control.Concurrent.MVar (newEmptyMVar,putMVar,takeMVar)+import Control.Exception (AsyncException(ThreadKilled,UserInterrupt),catch,fromException)+import Control.Monad (liftM)+import Control.Monad.IO.Class++import Data.Composition+import Data.Derive.Serialize+import Data.DeriveTH+import Data.Functor ((<$>))+import Data.IORef (atomicModifyIORef,IORef,newIORef,readIORef)+import qualified Data.IVar as IVar+import Data.IVar (IVar)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>),Monoid(..))+import Data.Sequence ((|>),(><),viewl,ViewL(..))+import Data.Serialize+import qualified Data.Sequence as Seq+import Data.Void (Void,absurd)++import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(DEBUG))+import System.Log.Logger.TH++import LogicGrowsOnTrees hiding (exploreTree,exploreTreeT,exploreTreeUntilFirst,exploreTreeTUntilFirst)+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Parallel.Purity+import LogicGrowsOnTrees.Path+import LogicGrowsOnTrees.Workload+++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++------------------------------ Worker responses --------------------------------++{-| A progress update sent to the supervisor;  it has a component which contains+    information about how much of the tree has been explored and what results+    have been found so far, as well as the remaining 'Workload' to be completed+    by this worker.+ -}+data ProgressUpdate progress = ProgressUpdate+    {   progressUpdateProgress :: progress+    ,   progressUpdateRemainingWorkload :: Workload+    } deriving (Eq,Show)+$( derive makeSerialize ''ProgressUpdate )++{-| A convenient type alias for the type of 'ProgressUpdate' associated with the+    given exploration mode.+ -}+type ProgressUpdateFor exploration_mode = ProgressUpdate (ProgressFor exploration_mode)++{-| A stolen workload sent to the supervisor;  in addition to a component with+    the stolen 'Workload' itself, it also has a 'ProgressUpdate' component,+    which is required in order to maintain the invariant that all of the+    'Workload's that the supervisor has on file (both assigned to workers and+    unassigned) plus the current progress equals the full tree.+ -}+data StolenWorkload progress = StolenWorkload+    {   stolenWorkloadProgressUpdate :: ProgressUpdate progress+    ,   stolenWorkload :: Workload+    } deriving (Eq,Show)+$( derive makeSerialize ''StolenWorkload )++{-| A convenient type alias for the type of 'StolenWorkload' associated with the+    the given exploration mode.+ -}+type StolenWorkloadFor exploration_mode = StolenWorkload (ProgressFor exploration_mode)++------------------------------- Worker requests --------------------------------++{-| A worker request. -}+data WorkerRequest progress =+    {-| Request that the worker abort. -}+    AbortRequested+    {-| Request that the worker respond with a progress update. -}+  | ProgressUpdateRequested (ProgressUpdate progress → IO ())+    {-| Request that the worker respond with a stolen workload (if possible). -}+  | WorkloadStealRequested (Maybe (StolenWorkload progress) → IO ())++{-| A queue of worker requests.++    NOTE:  Although the type is a list, and requests are added by prepending+    them to the list, it still acts as a queue because the worker will reverse+    the list before processing the requests.+-}+type WorkerRequestQueue progress = IORef [WorkerRequest progress]+{-| A convenient type alias for the type of 'WorkerRequestQueue' associated with+    the given exploration mode. -}+type WorkerRequestQueueFor exploration_mode = WorkerRequestQueue (ProgressFor exploration_mode)++--------------------------------- Worker types ---------------------------------++{-| The environment of a running worker. -}+data WorkerEnvironment progress = WorkerEnvironment+    {   workerInitialPath :: Path {-^ the initial path of the worker's workload -}+    ,   workerThreadId :: ThreadId {-^ the thread id of the worker thread -}+    ,   workerPendingRequests :: WorkerRequestQueue progress {-^ the request queue for the worker -}+    ,   workerTerminationFlag :: IVar () {-^ an IVar that is filled when the worker terminates -}+    }++{-| A convenient type alias for the type of 'WorkerEnvironment' associated with+    the given exploration mode. -}+type WorkerEnvironmentFor exploration_mode = WorkerEnvironment (ProgressFor exploration_mode)++{-| The reason why a worker terminated. -}+data WorkerTerminationReason worker_final_progress =+    {-| worker completed normally without error;  included is the final result -}+    WorkerFinished worker_final_progress+    {-| worker failed;  included is the message of the failure (this would have+        been a value of type 'SomeException' if it were not for the fact that+        this value will often have to be sent over communication channels and+        exceptions cannot be serialized (as they have unknown type), meaning+        that it usually has to be turned into a 'String' via 'show' anyway)+     -}+  | WorkerFailed String+    {-| worker was aborted by either an external request or the 'ThreadKilled' or 'UserInterrupt' exceptions -}+  | WorkerAborted+  deriving (Eq,Show)++{-| The 'Functor' instance lets you manipulate the final progress value when+    the termination reason is 'WorkerFinished'.+ -}+instance Functor WorkerTerminationReason where+    fmap f (WorkerFinished x) = WorkerFinished (f x)+    fmap _ (WorkerFailed x) = WorkerFailed x+    fmap _ WorkerAborted = WorkerAborted++{-| A convenient type alias for the type of 'WorkerTerminationReason' associated+    with the given exploration mode.+ -}+type WorkerTerminationReasonFor exploration_mode = WorkerTerminationReason (WorkerFinishedProgressFor exploration_mode)++{-| The action that a worker can take to push a result to the supervisor;  this+    type is effectively null (with the exact value 'absurd') for all modes+    except 'FoundModeUsingPush'.+ -}+type family WorkerPushActionFor exploration_mode :: *+-- NOTE:  Setting the below instances equal to Void → () is a hack around the+--        fact that using types with constructors result in a weird compiler bug.+type instance WorkerPushActionFor (AllMode result) = Void → ()+type instance WorkerPushActionFor (FirstMode result) = Void → ()+type instance WorkerPushActionFor (FoundModeUsingPull result) = Void → ()+type instance WorkerPushActionFor (FoundModeUsingPush result) = ProgressUpdate (Progress result) → IO ()++------------------------------- Tree properties --------------------------------++{-| Functions for working with a tree of a particular purity. -}+data TreeFunctionsForPurity (m :: * → *) (n :: * → *) (α :: *) =+    MonadIO n ⇒ TreeFunctionsForPurity+    {   walk :: Path → TreeT m α → n (TreeT m α)+    ,   step :: ExplorationTState m α → n (Maybe α,Maybe (ExplorationTState m α))+    ,   run ::  (∀ β. n β → IO β)+    }++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [DEBUG]++--------------------------------------------------------------------------------+----------------------------- Main worker function -----------------------------+--------------------------------------------------------------------------------++{-| The 'forkWorkerThread' function is the workhorse of the parallization+    infrastructure; it explores a tree in a separate thread while polling for+    requests. Specifically, the worker alternates between stepping through the+    tree and checking to see if there are any new requests in the queue.+    +    The worker is optimized around the observation that the vast majority of its+    time is spent exploring the tree rather than responding to requests, and so+    the amount of overhead needed to check if any requests are present needs to+    be minimized at the cost of possibly delaying a response to an incoming+    request. For this reason, it uses an 'IORef' for the queue to minimize the+    cost of peeking at it rather than an 'MVar' or some other thread+    synchronization variable; the trade-off is that if a request is added to the+    queue by a different processor then it might not be noticed immediately the+    caches get synchronized. Likewise, the request queue uses the List type+    rather than something like "Data.Sequence" for simplicity; the vast majority+    of the time the worker will encounter an empty list, and on the rare+    occasion when the list is non-empty it will be short enough that+    'reverse'ing it will not pose a significant cost.++    At any given point in the exploration, there is an initial path which+    locates the subtree that was given as the original workload, a cursor which+    indicates the subtree /within/ this subtree that makes up the /current/+    workload, and the context which indicates the current location in the+    subtree that is being explored. All workers start with an empty cursor; when+    a workload is stolen, decisions made early on in the the context are frozen+    and moved into the cursor because if they were not then when the worker+    backtracked it would explore a workload that it just gave away, resulting in+    some results being observed twice.++    The worker terminates either if it finishes exploring all the nodes in its+    (current) workload, if an error occurs, or if it is aborted either via.+    the 'ThreadKilled' and 'UserInterrupt' exceptions or by an abort request+    placed in the request queue.+ -}+forkWorkerThread ::+    ExplorationMode exploration_mode {-^ the mode in to explore the tree -} →+    Purity m n {-^ the purity of the tree -} →+    (WorkerTerminationReasonFor exploration_mode → IO ()) {-^ the action to run when the worker has terminated -} →+    TreeT m (ResultFor exploration_mode) {-^ the tree -} →+    Workload {-^ the workload for the worker -} →+    WorkerPushActionFor exploration_mode+        {-^ the action to push a result to the supervisor;  this should be equal+            to 'absurd' except when the exploration mode is 'FoundModeUsingPush'.+         -} →+    IO (WorkerEnvironmentFor exploration_mode) {-^ the environment for the worker -}+forkWorkerThread+    exploration_mode+    purity+    finishedCallback+    tree+    (Workload initial_path initial_checkpoint)+    push+  = do+    -- Note:  the following line of code needs to be this way --- that is, using+    --        do notation to extract the value of TreeFunctionsForPurity --- or else+    --        GHC's head will explode!+    TreeFunctionsForPurity{..} ← case getTreeFunctionsForPurity purity of x → return x+    pending_requests_ref ← newIORef []++    ------------------------------- LOOP PHASES --------------------------------+    let+    -- LOOP PHASE 1:  Check if there are any pending requests;  if so, proceed+    --                to phase 2;  otherwise (the most common case), skip to+    --                phase 3.+        loop1 (!result) cursor exploration_state =+            liftIO (readIORef pending_requests_ref) >>= \pending_requests →+            case pending_requests of+                [] → loop3 result cursor exploration_state+                _ → debugM "Worker thread's request queue is non-empty."+                    >> (liftM reverse . liftIO $ atomicModifyIORef pending_requests_ref (const [] &&& id))+                    >>= loop2 result cursor exploration_state++    -- LOOP PHASE 2:  Process all pending requests.+        loop2 result cursor exploration_state@(ExplorationTState context checkpoint tree) requests =+            case requests of+                [] → liftIO yield >> loop3 result cursor exploration_state+                AbortRequested:_ → do+                    debugM "Worker theread received abort request."+                    return WorkerAborted+                ProgressUpdateRequested submitProgress:rest_requests → do+                    debugM "Worker thread received progress update request."+                    liftIO . submitProgress $ computeProgressUpdate exploration_mode result initial_path cursor context checkpoint+                    loop2 initial_intermediate_value cursor exploration_state rest_requests+                WorkloadStealRequested submitMaybeWorkload:rest_requests → do+                    debugM "Worker thread received workload steal."+                    case tryStealWorkload initial_path cursor context of+                        Nothing → do+                            liftIO $ submitMaybeWorkload Nothing+                            loop2 result cursor exploration_state rest_requests+                        Just (new_cursor,new_context,workload) → do+                            liftIO . submitMaybeWorkload . Just $+                                StolenWorkload+                                    (computeProgressUpdate exploration_mode result initial_path new_cursor new_context checkpoint)+                                    workload+                            loop2 initial_intermediate_value new_cursor (ExplorationTState new_context checkpoint tree) rest_requests++    -- LOOP PHASE 3:  Take a step through the tree, and then (if not finished)+    --                return to phase 1.+        loop3 result cursor exploration_state+          = do+            (maybe_solution,maybe_new_exploration_state) ← step exploration_state +            case maybe_new_exploration_state of+                Nothing → -- We have completed exploring the tree.+                    let explored_checkpoint =+                            checkpointFromInitialPath initial_path+                            .+                            checkpointFromCursor cursor+                            $+                            Explored+                    in return . WorkerFinished $+                        -- NOTE:  Do *not* refactor the code below; if you do so+                        --        then it will confuse the type-checker.+                        case exploration_mode of+                            AllMode →+                                Progress+                                    explored_checkpoint+                                    (maybe result (result <>) maybe_solution)+                            FirstMode →+                                Progress+                                    explored_checkpoint+                                    maybe_solution+                            FoundModeUsingPull _ →+                                Progress+                                    explored_checkpoint+                                    (maybe result (result <>) maybe_solution)+                            FoundModeUsingPush _ →+                                Progress+                                    explored_checkpoint+                                    (fromMaybe mempty maybe_solution)+                Just new_exploration_state@(ExplorationTState context checkpoint _) →+                    let new_checkpoint = checkpointFromSetting initial_path cursor context checkpoint+                    in case maybe_solution of+                        Nothing → loop1 result cursor new_exploration_state+                        Just (!solution) →+                            case exploration_mode of+                                AllMode → loop1 (result <> solution) cursor new_exploration_state+                                FirstMode → return . WorkerFinished $ Progress new_checkpoint (Just solution)+                                FoundModeUsingPull f →+                                    let new_result = result <> solution+                                    in if f new_result+                                        then return . WorkerFinished $ Progress new_checkpoint new_result+                                        else loop1 new_result cursor new_exploration_state+                                FoundModeUsingPush _ → do+                                    liftIO . push $+                                        ProgressUpdate+                                            (Progress new_checkpoint solution)+                                            (workloadFromSetting initial_path cursor context checkpoint)+                                    loop1 () cursor new_exploration_state++    ----------------------------- LAUNCH THE WORKER ----------------------------+    finished_flag ← IVar.new+    thread_id ← forkIO $ do+        termination_reason ←+            debugM "Worker thread has been forked." >>+            (run $+                walk initial_path tree+                >>=+                loop1 initial_intermediate_value Seq.empty+                .+                initialExplorationState initial_checkpoint+            )+            `catch`+            (\e → case fromException e of+                Just ThreadKilled → return WorkerAborted+                Just UserInterrupt → return WorkerAborted+                _ → return $ WorkerFailed (show e)+            )+        debugM $ "Worker thread has terminated with reason " +++            case termination_reason of+                WorkerFinished _ → "finished."+                WorkerFailed message → "failed: " ++ show message+                WorkerAborted → "aborted."+        IVar.write finished_flag ()+        finishedCallback termination_reason+    return $+        WorkerEnvironment+            initial_path+            thread_id+            pending_requests_ref+            finished_flag+  where+    initial_intermediate_value = initialWorkerIntermediateValue exploration_mode+{-# INLINE forkWorkerThread #-}++--------------------------------------------------------------------------------+------------------------------ Request functions ------------------------------+--------------------------------------------------------------------------------++{-| Sends a request to abort. -}+sendAbortRequest :: WorkerRequestQueue progress → IO ()+sendAbortRequest = flip sendRequest AbortRequested++{-| Sends a request for a progress update along with a response action to+    perform when the progress update is available.+ -}+sendProgressUpdateRequest ::+    WorkerRequestQueue progress {-^ the request queue -} →+    (ProgressUpdate progress → IO ()) {-^ the action to perform when the update is available -} →+    IO ()+sendProgressUpdateRequest queue = sendRequest queue . ProgressUpdateRequested++{-| Sends a request to steal a workload along with a response action to+    perform when the progress update is available.+ -}+sendWorkloadStealRequest ::+    WorkerRequestQueue progress {-^ the request queue -} →+    (Maybe (StolenWorkload progress) → IO ()) {-^ the action to perform when the update is available -} →+    IO ()+sendWorkloadStealRequest queue = sendRequest queue . WorkloadStealRequested++{-| Sends a request to a worker. -}+sendRequest :: WorkerRequestQueue progress → WorkerRequest progress → IO ()+sendRequest queue request = atomicModifyIORef queue ((request:) &&& const ())++--------------------------------------------------------------------------------+------------------------------ Utility functions -------------------------------+--------------------------------------------------------------------------------++{-| Explores a tree with the specified purity using the given mode by forking a+    worker thread and waiting for it to finish; it exists to facilitate testing+    and benchmarking and is not a function that you are likely to ever have a+    need for yourself.+ -}+exploreTreeGeneric ::+    ( WorkerPushActionFor exploration_mode ~ (Void → ())+    , ResultFor exploration_mode ~ α+    ) ⇒+    ExplorationMode exploration_mode →+    Purity m n →+    TreeT m α →+    IO (WorkerTerminationReason (FinalResultFor exploration_mode))+exploreTreeGeneric exploration_mode purity tree = do+    final_progress_mvar ← newEmptyMVar+    _ ← forkWorkerThread+            exploration_mode+            purity+            (putMVar final_progress_mvar)+            tree+            entire_workload+            absurd+    final_progress ← takeMVar final_progress_mvar+    return . flip fmap final_progress $ \progress →+        case exploration_mode of+            AllMode → progressResult progress+            FirstMode → Progress (progressCheckpoint progress) <$> progressResult progress+            FoundModeUsingPull f →+                if f (progressResult progress)+                    then Right progress+                    else Left (progressResult progress)+            _ → error "should never reach here due to incompatible types"++--------------------------------------------------------------------------------+------------------------------ Internal functions ------------------------------+--------------------------------------------------------------------------------++checkpointFromSetting ::+    Path →+    CheckpointCursor →+    Context m α →+    Checkpoint →+    Checkpoint+checkpointFromSetting initial_path cursor context =+     checkpointFromInitialPath initial_path+     .+     checkpointFromCursor cursor+     .+     checkpointFromContext context++computeProgressUpdate ::+    ResultFor exploration_mode ~ α ⇒+    ExplorationMode exploration_mode →+    WorkerIntermediateValueFor exploration_mode →+    Path →+    CheckpointCursor →+    Context m α →+    Checkpoint →+    ProgressUpdate (ProgressFor exploration_mode)+computeProgressUpdate exploration_mode result initial_path cursor context checkpoint =+    ProgressUpdate+        (case exploration_mode of+            AllMode → Progress full_checkpoint result+            FirstMode → full_checkpoint+            FoundModeUsingPull _ → Progress full_checkpoint result+            FoundModeUsingPush _ → Progress full_checkpoint mempty+        )+        (workloadFromSetting initial_path cursor context checkpoint)+  where+    full_checkpoint = checkpointFromSetting initial_path cursor context checkpoint++getTreeFunctionsForPurity :: Purity m n → TreeFunctionsForPurity m n α+getTreeFunctionsForPurity Pure = TreeFunctionsForPurity{..}+  where+    walk = return .* sendTreeDownPath+    step = return . stepThroughTreeStartingFromCheckpoint+    run = id+getTreeFunctionsForPurity (ImpureAtopIO run) = TreeFunctionsForPurity{..}+  where+    walk = sendTreeTDownPath+    step = stepThroughTreeTStartingFromCheckpoint+{-# INLINE getTreeFunctionsForPurity #-}++tryStealWorkload ::+    Path →+    CheckpointCursor →+    Context m α →+    Maybe (CheckpointCursor,Context m α,Workload)+tryStealWorkload initial_path = go+  where+    go cursor context =+        case viewl context of+            EmptyL → Nothing+            CacheContextStep cache :< rest_context →+                go (cursor |> CachePointD cache) rest_context+            LeftBranchContextStep other_checkpoint _ :< rest_context →+                Just (cursor |> ChoicePointD LeftBranch Unexplored+                     ,rest_context+                     ,Workload+                        ((initial_path >< pathFromCursor cursor) |> ChoiceStep RightBranch)+                        other_checkpoint+                     )+            RightBranchContextStep :< rest_context →+                go (cursor |> ChoicePointD RightBranch Explored) rest_context++workloadFromSetting ::+    Path →+    CheckpointCursor →+    Context m α →+    Checkpoint →+    Workload+workloadFromSetting initial_path cursor context =+    Workload (initial_path >< pathFromCursor cursor)+    .+    checkpointFromContext context
+ sources/LogicGrowsOnTrees/Parallel/Common/Workgroup.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module provides most of the common functionality needed to implement a+    adapter where the number of workers can be adjusted during the run.+ -}+module LogicGrowsOnTrees.Parallel.Common.Workgroup+    (+    -- * Type-classes+      WorkgroupRequestQueueMonad(..)+    -- * Types+    , InnerMonad+    , MessageForSupervisorReceivers(..)+    , WorkerId+    , WorkgroupCallbacks(..)+    , WorkgroupControllerMonad(..)+    -- * Functions+    -- ** Worker count adjustment+    , changeNumberOfWorkers+    , setNumberOfWorkersAsync+    , setNumberOfWorkers+    -- ** Runner+    , runWorkgroup+    ) where++import Control.Applicative (Applicative,(<$>))+import Control.Lens (makeLenses)+import Control.Lens.Getter (use)+import Control.Lens.Lens ((<<%=))+import Control.Lens.Setter ((.=),(%=))+import Control.Monad (forM_,replicateM_,void)+import Control.Monad.CatchIO (MonadCatchIO)+import Control.Monad.IO.Class (MonadIO,liftIO)+import Control.Monad.Reader.Class (asks)+import Control.Monad.State.Class (MonadState)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT,ask,runReaderT)+import Control.Monad.Trans.State.Strict (StateT,evalStateT)++import Data.Composition ((.*))+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Monoid (Monoid(mempty))+import Data.PSQueue (Binding((:->)),PSQ)+import qualified Data.PSQueue as PSQ+import Data.Word (Word,Word64)++import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(INFO))+import System.Log.Logger.TH++import Text.Printf (printf)++import LogicGrowsOnTrees.Parallel.Common.Message+import LogicGrowsOnTrees.Parallel.Common.RequestQueue+import LogicGrowsOnTrees.Parallel.Common.Supervisor+import LogicGrowsOnTrees.Parallel.Main (RunOutcomeFor,extractRunOutcomeFromSupervisorOutcome)+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Workload++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [INFO]++--------------------------------------------------------------------------------+--------------------------------- Type-classes ---------------------------------+--------------------------------------------------------------------------------++{-| A 'WorkgroupRequestQueueMonad' is a 'RequestQueueMonad' but with the+    additional ability to change the number of workers in the system.+ -}+class RequestQueueMonad m ⇒ WorkgroupRequestQueueMonad m where+    {-| Change the number of workers;  the first argument is a map that computes+        the new number of workers given the old number of workers, and the+        second argument is a callback that will be invoked with the new number+        of workers.++        See 'changeNumberOfWorkers' for the synchronous version of this request.++        If you just want to set the number of workers to some fixed value, then+        see 'setNumberOfWorkers' / 'setNumberOfWorkersAsync'.+     -}+    changeNumberOfWorkersAsync :: (Word → Word) → (Word → IO ()) → m ()++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++{-| The type of worker ids used by this module (an alias for 'Int'). -}+type WorkerId = Int++type RemovalPriority = Word64++{-| This is the monad in which the adapter specific code is run. -}+type InnerMonad inner_state = StateT inner_state IO++{-| A set of callbacks invoked by the supervisor code in this module. -}+data WorkgroupCallbacks inner_state = WorkgroupCallbacks+    {   {-| create a worker with the given id -}+        createWorker :: WorkerId → InnerMonad inner_state ()+        {-| destroy the worker with the given id; ideally this should be+            implemented by signaling the worker to quit and then waiting for an+            acknowledgement+         -}+    ,   destroyWorker :: WorkerId → Bool → InnerMonad inner_state ()+        {-| destroy all of the workers in the given list in a manner that+            ensures they all terminate promptly; this will be called at the end+            of the run (successful or not)+         -}+    ,   killAllWorkers :: [WorkerId] → InnerMonad inner_state ()+        {-| send a progress update request to the given worker -}+    ,   sendProgressUpdateRequestTo :: WorkerId → InnerMonad inner_state ()+        {-| send a workload steal request to the given worker -}+    ,   sendWorkloadStealRequestTo :: WorkerId → InnerMonad inner_state ()+        {-| send a workload to the given worker -}+    ,   sendWorkloadTo :: WorkerId → Workload → InnerMonad inner_state ()+    }++data WorkgroupState = WorkgroupState+    {   _pending_quit :: !IntSet+    ,   _next_worker_id :: !WorkerId+    ,   _next_priority :: !RemovalPriority+    ,   _removal_queue :: !(PSQ WorkerId RemovalPriority)+    }+$( makeLenses ''WorkgroupState )+++type WorkgroupStateMonad inner_state = StateT WorkgroupState (ReaderT (WorkgroupCallbacks inner_state) (InnerMonad inner_state))++type WorkgroupMonad inner_state exploration_mode = SupervisorMonad exploration_mode WorkerId (WorkgroupStateMonad inner_state)++{-| This is the monad in which the workgroup controller will run. -}+newtype WorkgroupControllerMonad inner_state exploration_mode α = C { unwrapC :: RequestQueueReader exploration_mode WorkerId (WorkgroupStateMonad inner_state) α} deriving (Applicative,Functor,Monad,MonadCatchIO,MonadIO,RequestQueueMonad)++instance HasExplorationMode (WorkgroupControllerMonad inner_state exploration_mode) where+    type ExplorationModeFor (WorkgroupControllerMonad inner_state exploration_mode) = exploration_mode++instance WorkgroupRequestQueueMonad (WorkgroupControllerMonad inner_state exploration_mode) where+    changeNumberOfWorkersAsync computeNewNumberOfWorkers receiveNewNumberOfWorkers = C $ ask >>= (enqueueRequest $ do+        old_number_of_workers ← numberOfWorkers+        let new_number_of_workers = computeNewNumberOfWorkers old_number_of_workers+        case new_number_of_workers `compare` old_number_of_workers of+            GT → replicateM_ (fromIntegral $ new_number_of_workers - old_number_of_workers) hireAWorker+            LT → replicateM_ (fromIntegral $ old_number_of_workers - new_number_of_workers) fireAWorker+            EQ → return ()+        infoM $ printf "Number of workers has been changed from %i to %i" old_number_of_workers new_number_of_workers+        liftIO . receiveNewNumberOfWorkers $ new_number_of_workers+     )++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++--------------------------- Worker count adjustment ----------------------------++{-| Like 'changeNumberOfWorkersAsync', but it blocks until the number of workers+    has been changed and returns the new number of workers.+ -}+changeNumberOfWorkers :: WorkgroupRequestQueueMonad m ⇒ (Word → Word) → m Word+changeNumberOfWorkers = syncAsync . changeNumberOfWorkersAsync++{-| Request that the number of workers be set to the given amount, invoking the given callback when this has been done. -}+setNumberOfWorkersAsync :: WorkgroupRequestQueueMonad m ⇒ Word → IO () → m ()+setNumberOfWorkersAsync n callback = changeNumberOfWorkersAsync (const n) (const callback)++{-| Like 'setNumberOfWorkersAsync', but blocks until the number of workers has been set to the desired value. -}+setNumberOfWorkers :: WorkgroupRequestQueueMonad m ⇒ Word → m ()+setNumberOfWorkers = void . syncAsync . changeNumberOfWorkersAsync . const++{-| Explores a tree using a workgroup;  this function is only intended to be+    used by adapters where the number of workers can be changed on demand.+ -}+runWorkgroup ::+    ExplorationMode exploration_mode {-^ the mode in which we are exploring the tree -} →+    inner_state {-^ the initial adapter specific state of the inner monad -} →+    (MessageForSupervisorReceivers exploration_mode WorkerId → WorkgroupCallbacks inner_state)+        {-^ a function that constructs a set of callbacks to be used by the+            supervisor loop in this function to do things like creating and+            destroying workers;  it is given a set of callbacks that allows the+            adapter specific code to signal conditions to the supervisor+         -} →+    ProgressFor exploration_mode {-^ the initial progress of the exploration -} →+    WorkgroupControllerMonad inner_state exploration_mode () {-^ the controller, which is at the very least responsible for deciding how many workers should be initially created -} →+    IO (RunOutcomeFor exploration_mode)+runWorkgroup exploration_mode initial_inner_state constructCallbacks starting_progress (C controller) = do+    request_queue ← newRequestQueue+    let receiveStolenWorkloadFromWorker = flip enqueueRequest request_queue .* receiveStolenWorkload+        receiveProgressUpdateFromWorker = flip enqueueRequest request_queue .* receiveProgressUpdate+        receiveFailureFromWorker = flip enqueueRequest request_queue .* receiveWorkerFailure+        receiveFinishedFromWorker worker_id final_progress = flip enqueueRequest request_queue $ do+            removal_flag ← IntSet.member worker_id <$> use pending_quit+            infoM $ if removal_flag+                then "Worker " ++ show worker_id ++ " has finished, and will be removed."+                else "Worker " ++ show worker_id ++ " has finished, and will look for another workload."+            receiveWorkerFinishedWithRemovalFlag removal_flag worker_id final_progress++        receiveQuitFromWorker worker_id = flip enqueueRequest request_queue $ do+            infoM $ "Worker " ++ show worker_id ++ " has quit."+            quitting ← IntSet.member worker_id <$> (pending_quit <<%= IntSet.delete worker_id)+            if quitting+                then removeWorkerIfPresent worker_id+                else receiveWorkerFailure worker_id $ "Worker " ++ show worker_id ++ " quit prematurely."++        broadcastProgressUpdateToWorkers = \worker_ids →+            asks sendProgressUpdateRequestTo >>= liftInner . forM_ worker_ids+        broadcastWorkloadStealToWorkers = \worker_ids →+            asks sendWorkloadStealRequestTo >>= liftInner . forM_ worker_ids+        receiveCurrentProgress = receiveProgress request_queue+        sendWorkloadToWorker = \workload worker_id → do+            infoM $ "Activating worker " ++ show worker_id ++ " with workload " ++ show workload+            asks sendWorkloadTo >>= liftInner . ($ workload) . ($ worker_id)+            bumpWorkerRemovalPriority worker_id+    forkControllerThread request_queue controller+    run_outcome ←+        flip evalStateT initial_inner_state+        .+        flip runReaderT (constructCallbacks MessageForSupervisorReceivers{..})+        .+        flip evalStateT initial_state+        $+        do  supervisor_outcome@SupervisorOutcome{supervisorRemainingWorkers} ←+                runSupervisorStartingFrom+                    exploration_mode+                    starting_progress+                    SupervisorCallbacks{..}+                    (requestQueueProgram (return ()) request_queue)+            asks killAllWorkers >>= liftInner . ($ supervisorRemainingWorkers)+            return $ extractRunOutcomeFromSupervisorOutcome supervisor_outcome+    killControllerThreads request_queue+    return run_outcome+  where+    initial_state =+        WorkgroupState+            {   _pending_quit = mempty+            ,   _next_worker_id = 0+            ,   _next_priority = maxBound+            ,   _removal_queue = PSQ.empty+            }++--------------------------------------------------------------------------------+------------------------------ Internal Functions ------------------------------+--------------------------------------------------------------------------------++bumpWorkerRemovalPriority ::+    (MonadState WorkgroupState m) ⇒+    WorkerId →+    m ()+bumpWorkerRemovalPriority worker_id =+    (next_priority <<%= pred) >>= (removal_queue %=) . PSQ.insert worker_id++fireAWorker :: WorkgroupMonad inner_state exploration_mode ()+fireAWorker =+    tryGetWaitingWorker+    >>= \x → case x of+        Just worker_id → do+            infoM $ "Removing waiting worker " ++ show worker_id ++ "."+            removeWorker worker_id+            removeWorkerFromRemovalQueue worker_id+            pending_quit %= IntSet.insert worker_id+            asks destroyWorker >>= liftInnerToSupervisor . ($ False) . ($ worker_id)+        Nothing → do+            (worker_id,new_removal_queue) ← do+               (PSQ.minView <$> use removal_queue) >>=+                    \x → case x of+                        Nothing → error "No workers found to be removed!"+                        Just (worker_id :-> _,rest_queue) → return (worker_id,rest_queue)+            infoM $ "Removing active worker " ++ show worker_id ++ "."+            removal_queue .= new_removal_queue+            pending_quit %= IntSet.insert worker_id+            asks destroyWorker >>= liftInnerToSupervisor . ($ True) . ($ worker_id)++hireAWorker :: WorkgroupMonad inner_state exploration_mode ()+hireAWorker = do+    worker_id ← next_worker_id <<%= succ+    bumpWorkerRemovalPriority worker_id+    asks createWorker >>= liftInnerToSupervisor . ($ worker_id)+    addWorker worker_id++liftInner :: InnerMonad inner_state α → WorkgroupStateMonad inner_state α+liftInner = lift . lift++liftInnerToSupervisor :: InnerMonad inner_state α → WorkgroupMonad inner_state exploration_mode α+liftInnerToSupervisor = lift . liftInner++numberOfWorkers :: WorkgroupMonad inner_state exploration_mode Word+numberOfWorkers = fromIntegral . PSQ.size <$> use removal_queue++removeWorkerFromRemovalQueue :: WorkerId → WorkgroupMonad inner_state exploration_mode ()+removeWorkerFromRemovalQueue = (removal_queue %=) . PSQ.delete
+ sources/LogicGrowsOnTrees/Parallel/ExplorationMode.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| There are several tasks for which a user may wish to use LogicGrowsOnTrees,+    such as gathering up all the results in a tree or stopping as soon as the+    first result is found. Because almost all of the infrastructure required for+    these different modes is the same, rather than creating a different system+    for each mode we instead re-use the same system but pass around a mode+    parameter that dictates its behavior at various points as well as some of+    the types in the system.++    'ExplorationMode' is defined using a GADT where each constructor has a+    different argument for `ExplorationMode`\'s type parameter; this was+    done so that type families can be used to specialized types depending on the+    constructor.+ -}+module LogicGrowsOnTrees.Parallel.ExplorationMode+    (+    -- * Types+      ExplorationMode(..)+    , AllMode+    , FirstMode+    , FoundModeUsingPull+    , FoundModeUsingPush+    -- * Type-classes+    , HasExplorationMode(..)+    -- * Type families+    , ResultFor+    , ProgressFor+    , FinalResultFor+    , WorkerIntermediateValueFor+    , WorkerFinishedProgressFor+    -- * Functions+    , checkpointFromIntermediateProgress+    , initialProgress+    , initialWorkerIntermediateValue+    ) where+++import Data.Monoid++import LogicGrowsOnTrees.Checkpoint++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++{-| A type indicating the mode of the exploration.  Note that this is a GADT for+    which the type parameter is unique to each constructor in order to allow+    associated types to be specialized based on the value.++    Unfortunately Haddock does not seem to support documenting the constructors+    of a GADT, so the documentation for each constructor is located at the type+    it is tagged with, all of which are defined after the 'ExplorationMode'+    type.+ -}+data ExplorationMode exploration_mode where+    AllMode :: Monoid result ⇒ ExplorationMode (AllMode result)+    FirstMode :: ExplorationMode (FirstMode result)+    FoundModeUsingPull :: Monoid result ⇒ (result → Bool) → ExplorationMode (FoundModeUsingPull result)+    FoundModeUsingPush :: Monoid result ⇒ (result → Bool) → ExplorationMode (FoundModeUsingPush result)++{-| Explore the entire tree and sum the results in all of the leaves. -}+data AllMode result+{-| Explore the tree until a result is found, and if so then stop. -}+data FirstMode result+{-| Explore the tree, summing the results, until a condition has been met;+    `Pull` means that each worker's results will be kept and summed locally+    until a request for them has been received from the supervisor, which means+    that there might be a period of time where the collectively found results+    meet the condition but the system is unaware of this as they are scattered+    amongst the workers.++    NOTE:  If you use this mode then you are responsible for ensuring that a+           global progress update happens on a regular basis in order to pull+           the results in from the workers and check to see if the condition has+           been met;  if you do not do this then the run will not terminate+           until the tree has been fully explored.+ -}+data FoundModeUsingPull result+{-| Same as 'FoundModeUsingPull', but pushes each result to the supervisor as it+    is found rather than summing them in the worker until they are requested by+    the supervisor, which guarantees that the system will recognize when the+    condition has been met as soon as final result needed was found but has the+    downside that if there are a large number of results needed then sending+    each one could be much more costly then summing them locally and sending the+    current total on a regular basis to the supervisor.+ -}+data FoundModeUsingPush result++--------------------------------------------------------------------------------+--------------------------------- Type-classes ---------------------------------+--------------------------------------------------------------------------------++{-| This class indicates that a monad has information about the current+    exploration mode tag type that can be extracted from it.+ -}+class HasExplorationMode (monad :: * → *) where+    type ExplorationModeFor monad :: *++--------------------------------------------------------------------------------+-------------------------------- Type families ---------------------------------+--------------------------------------------------------------------------------++{- $families+The type families in this section allow the types to be used at various places+to be specialized based on the current exploration mode.+-}++{-| The result type of the tree, i.e. the type of values at the leaves. -}+type family ResultFor exploration_mode :: *+type instance ResultFor (AllMode result) = result+type instance ResultFor (FirstMode result) = result+type instance ResultFor (FoundModeUsingPull result) = result+type instance ResultFor (FoundModeUsingPush result) = result++{-| The type of progress, which keeps track of how much of the tree has already+    been explored.+ -}+type family ProgressFor exploration_mode :: *+type instance ProgressFor (AllMode result) = Progress result+type instance ProgressFor (FirstMode result) = Checkpoint+type instance ProgressFor (FoundModeUsingPull result) = Progress result+type instance ProgressFor (FoundModeUsingPush result) = Progress result++{-| The type of the final result of exploring the tree. -}+type family FinalResultFor exploration_mode :: *+type instance FinalResultFor (AllMode result) = result+type instance FinalResultFor (FirstMode result) = Maybe (Progress result)+type instance FinalResultFor (FoundModeUsingPull result) = Either result (Progress result)+type instance FinalResultFor (FoundModeUsingPush result) = Either result (Progress result)++{-| The type of the intermediate value being maintained internally by the worker. -}+type family WorkerIntermediateValueFor exploration_mode :: *+type instance WorkerIntermediateValueFor (AllMode result) = result+type instance WorkerIntermediateValueFor (FirstMode result) = ()+type instance WorkerIntermediateValueFor (FoundModeUsingPull result) = result+type instance WorkerIntermediateValueFor (FoundModeUsingPush result) = ()++{-| The progress type returned by a worker that has finished. -}+type family WorkerFinishedProgressFor exploration_mode :: *+type instance WorkerFinishedProgressFor (AllMode result) = Progress result+type instance WorkerFinishedProgressFor (FirstMode result) = Progress (Maybe result)+type instance WorkerFinishedProgressFor (FoundModeUsingPull result) = Progress result+type instance WorkerFinishedProgressFor (FoundModeUsingPush result) = Progress result++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++{-| Extracts the 'Checkpoint' component from a progress value. -}+checkpointFromIntermediateProgress ::+    ExplorationMode exploration_mode →+    ProgressFor exploration_mode →+    Checkpoint+checkpointFromIntermediateProgress AllMode = progressCheckpoint+checkpointFromIntermediateProgress FirstMode = id+checkpointFromIntermediateProgress (FoundModeUsingPull _) = progressCheckpoint+checkpointFromIntermediateProgress (FoundModeUsingPush _) = progressCheckpoint++{-| The initial progress at the start of the exploration. -}+initialProgress :: ExplorationMode exploration_mode → ProgressFor exploration_mode+initialProgress AllMode = mempty+initialProgress FirstMode = mempty+initialProgress (FoundModeUsingPull _) = mempty+initialProgress (FoundModeUsingPush _) = mempty++{-| The initial intermediate value for the worker. -}+initialWorkerIntermediateValue ::+    ExplorationMode exploration_mode →+    WorkerIntermediateValueFor exploration_mode+initialWorkerIntermediateValue AllMode = mempty+initialWorkerIntermediateValue FirstMode = ()+initialWorkerIntermediateValue (FoundModeUsingPull _) = mempty+initialWorkerIntermediateValue (FoundModeUsingPush _) = ()
+ sources/LogicGrowsOnTrees/Parallel/Main.hs view
@@ -0,0 +1,1292 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}++{-| This module provides a framework for creating a program that explores a tree+    in parallel. There are two families of functions that are available. The+    first is more general and allows you to construct your tree using arguments+    given on the command-line; they are described in the section linked to by+    "LogicGrowsOnTrees.Parallel.Main#main". If you do not need run-time+    information via a command-line argument to construct the tree, then you may+    prefer the simpler family of functions which are described in the section+    linked to by "LogicGrowsOnTrees.Parallel.Main#main-simple".++    All of this functionality is adapter independent, so if you want to use a+    different back end you only need to change the driver argument and+    recompile.+ -}+module LogicGrowsOnTrees.Parallel.Main+    (+    -- * Types+    -- ** Driver types+      Driver(..)+    , DriverParameters(..)+    -- ** Outcome types+    , RunOutcome(..)+    , RunOutcomeFor+    , RunStatistics(..)+    , TerminationReason(..)+    , TerminationReasonFor+    -- * Main functions+    -- $main++    -- ** Sum over all results+    -- $all+    , mainForExploreTree+    , mainForExploreTreeIO+    , mainForExploreTreeImpure+    -- ** Stop at first result+    -- $first+    , mainForExploreTreeUntilFirst+    , mainForExploreTreeIOUntilFirst+    , mainForExploreTreeImpureUntilFirst+    -- ** Stop when sum of results found+    -- $found++    -- *** Pull+    -- $pull+    , mainForExploreTreeUntilFoundUsingPull+    , mainForExploreTreeIOUntilFoundUsingPull+    , mainForExploreTreeImpureUntilFoundUsingPull+    -- *** Push+    -- $push+    , mainForExploreTreeUntilFoundUsingPush+    , mainForExploreTreeIOUntilFoundUsingPush+    , mainForExploreTreeImpureUntilFoundUsingPush+    -- ** Generic main function+    , genericMain+    -- * Simple main functions+    -- $main-simple++    -- ** Sum over all results+    -- $all-simple+    , simpleMainForExploreTree+    , simpleMainForExploreTreeIO+    , simpleMainForExploreTreeImpure+    -- ** Stop at first result+    -- $first-simple+    , simpleMainForExploreTreeUntilFirst+    , simpleMainForExploreTreeIOUntilFirst+    , simpleMainForExploreTreeImpureUntilFirst+    -- ** Stop when sum of results found+    -- $found-simple++    -- *** Pull+    -- $pull-simple+    , simpleMainForExploreTreeUntilFoundUsingPull+    , simpleMainForExploreTreeIOUntilFoundUsingPull+    , simpleMainForExploreTreeImpureUntilFoundUsingPull+    -- *** Push+    -- $push-simple+    , simpleMainForExploreTreeUntilFoundUsingPush+    , simpleMainForExploreTreeIOUntilFoundUsingPush+    , simpleMainForExploreTreeImpureUntilFoundUsingPush+    -- * Utility functions+    , extractRunOutcomeFromSupervisorOutcome+    , mainParser+    ) where++import Prelude hiding (readFile,writeFile)++import Control.Applicative ((<$>),(<*>),pure)+import Control.Concurrent (ThreadId,killThread,threadDelay)+import Control.Exception (finally,handleJust,onException)+import Control.Monad (forever,liftM,mplus,when)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Tools (ifM)++import Data.ByteString.Lazy (readFile,writeFile)+import Data.Char (toLower)+import Data.Composition ((.*))+import Data.Derive.Serialize+import Data.DeriveTH+import Data.Functor.Identity (Identity)+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid(..))+import Data.Prefix.Units (FormatMode(FormatSiAll),formatValue,unitName)+import Data.Serialize++import System.Console.CmdTheLine+import System.Directory (doesFileExist,removeFile,renameFile)+import System.Environment (getProgName)+import System.IO (hPutStr,hPutStrLn,stderr)+import System.IO.Error (isDoesNotExistError)+import qualified System.Log.Logger as Logger+import System.Log.Logger (Priority(..),setLevel,rootLoggerName,updateGlobalLogger)+import System.Log.Logger.TH++import Text.Printf (printf)++import LogicGrowsOnTrees (Tree,TreeIO,TreeT)+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Parallel.Common.RequestQueue+import LogicGrowsOnTrees.Parallel.Common.Supervisor+    ( FunctionOfTimeStatistics(..)+    , IndependentMeasurementsStatistics(..)+    , RunStatistics(..)+    , SupervisorTerminationReason(..)+    , SupervisorOutcome(..)+    )+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Parallel.Purity++--------------------------------------------------------------------------------+----------------------------------- Loggers ------------------------------------+--------------------------------------------------------------------------------++deriveLoggers "Logger" [INFO,NOTICE]++--------------------------------------------------------------------------------+------------------------------------ Types -------------------------------------+--------------------------------------------------------------------------------++-------------------------------- Configuration ---------------------------------++data CheckpointConfiguration = CheckpointConfiguration+    {   checkpoint_path :: FilePath+    ,   checkpoint_interval :: Float+    } deriving (Eq,Show)++data LoggingConfiguration = LoggingConfiguration+    {   log_level :: Priority+    } deriving (Eq,Show)+instance Serialize LoggingConfiguration where+    put = put . show . log_level+    get = LoggingConfiguration . read <$> get++data StatisticsConfiguration = StatisticsConfiguration+    {   show_wall_times :: !Bool+    ,   show_supervisor_occupation :: !Bool+    ,   show_supervisor_monad_occupation :: !Bool+    ,   show_supervisor_calls :: !Bool+    ,   show_worker_occupation :: !Bool+    ,   show_worker_wait_times :: !Bool+    ,   show_steal_wait_times :: !Bool+    ,   show_numbers_of_waiting_workers :: !Bool+    ,   show_numbers_of_available_workloads :: !Bool+    ,   show_instantaneous_workload_request_rates :: !Bool+    ,   show_instantaneous_workload_steal_times :: !Bool+    } deriving (Eq,Show)++data SupervisorConfiguration = SupervisorConfiguration+    {   maybe_checkpoint_configuration :: Maybe CheckpointConfiguration+    ,   maybe_workload_buffer_size_configuration :: Maybe Int+    ,   statistics_configuration :: StatisticsConfiguration+    } deriving (Eq,Show)++data SharedConfiguration tree_configuration = SharedConfiguration+    {   logging_configuration :: LoggingConfiguration+    ,   tree_configuration :: tree_configuration+    } deriving (Eq,Show)+$( derive makeSerialize ''SharedConfiguration )++--------------------------------- Driver types ---------------------------------++{-| The 'Driver' is the core type that abstracts the various adapters behind a+    common interface that can be invoked by the main functions; it specifies a+    function that is called to start the run with a set of parameters specified+    in 'DriverParameters'.++    (Unfortunately in haddock the type signature below can be difficult to read+    because it puts all of the type on a single line; the type is essentially+    just a map from 'DriverParameters' to @result_monad ()@, but involving a+    bunch of type variables and some constraints on them. It might be easier to+    click the link to go to the source.)++    Note that the @controller_monad@ type parameter is within an existential+    type; this is because the user of the driver should not need to know what it+    is.+ -}+data Driver+    result_monad+    shared_configuration+    supervisor_configuration+    m n+    exploration_mode+  = ∀ controller_monad.+    ( RequestQueueMonad (controller_monad exploration_mode)+    , ExplorationModeFor (controller_monad exploration_mode) ~ exploration_mode+    ) ⇒+    Driver (+        ( Serialize (ProgressFor exploration_mode)+        , MonadIO result_monad+        ) ⇒+        DriverParameters+            shared_configuration+            supervisor_configuration+            m n+            exploration_mode+            controller_monad+        → result_monad ()+    )++{-| The 'DriverParameters' type specifies the information that is given to the+    driver in the main functions.+ -}+data DriverParameters+    shared_configuration+    supervisor_configuration+    m n+    exploration_mode+    controller_monad =+    DriverParameters+    {   {-| configuration information shared between the supervisor and the worker -}+        shared_configuration_term :: Term shared_configuration+        {-| configuration information specific to the supervisor -}+    ,   supervisor_configuration_term :: Term supervisor_configuration+        {-| program information;  should at a minimum put a brief description of the program in the 'termDoc' field -}+    ,   program_info :: TermInfo+        {-| action that initializes the global state of each process --- that+            is, once for each running instance of the executable, which+            depending on the adapter might be a supervisor, a worker, or both+         -}+    ,   initializeGlobalState :: shared_configuration → IO ()+        {-| in the supervisor, gets the starting progress for the exploration;  this is where a checkpoint is loaded, if one exists -}+    ,   getStartingProgress :: shared_configuration → supervisor_configuration → IO (ProgressFor exploration_mode)+        {-| in the supervisor, responds to the termination of the run -}+    ,   notifyTerminated :: shared_configuration → supervisor_configuration → RunOutcomeFor exploration_mode → IO ()+        {-| constructs the exploration mode given the shared configuration -}+    ,   constructExplorationMode :: shared_configuration → ExplorationMode exploration_mode+        {-| constructs the tree given the shared configuration -}+    ,   constructTree :: shared_configuration → TreeT m (ResultFor exploration_mode)+        {-| the purity of the constructed tree -}+    ,   purity :: Purity m n+        {-| construct the controller, which runs in the supervisor and handles things like periodic checkpointing -}+    ,   constructController :: shared_configuration → supervisor_configuration → controller_monad exploration_mode ()+    }++-------------------------------- Outcome types ---------------------------------++{-| A type that represents the outcome of a run. -}+data RunOutcome progress final_result = RunOutcome+    {   {-| statistics gathered during the run, useful if the system is not scaling with the number of workers as it should -}+        runStatistics :: RunStatistics+        {-| the reason why the run terminated -}+    ,   runTerminationReason :: TerminationReason progress final_result+    } deriving (Eq,Show)++{-| A convenient type alias for the type of 'RunOutcome' associated with the given exploration mode. -}+type RunOutcomeFor exploration_mode = RunOutcome (ProgressFor exploration_mode) (FinalResultFor exploration_mode)++{-| A type that represents the reason why a run terminated. -}+data TerminationReason progress final_result =+    {-| the run was aborted with the given progress -}+    Aborted progress+    {-| the run completed with the given final result -}+  | Completed final_result+    {-| the run failed with the given progress for the given reason -}+  | Failure progress String+  deriving (Eq,Show)++{-| A convenient type alias for the type of 'TerminationReason' associated with the given exploration mode. -}+type TerminationReasonFor exploration_mode = TerminationReason (ProgressFor exploration_mode) (FinalResultFor exploration_mode)++--------------------------------------------------------------------------------+---------------------------------- Instances -----------------------------------+--------------------------------------------------------------------------------++instance ArgVal Priority where+    converter = enum $+        [DEBUG,INFO,NOTICE,WARNING,ERROR,CRITICAL,ALERT,EMERGENCY]+        >>=+        \level → let name = show level+                 in return (name,level) `mplus` return (map toLower name,level)++--------------------------------------------------------------------------------+-------------------------------- Main functions --------------------------------+--------------------------------------------------------------------------------++{- $main #main#+The functions in this section all provide a main function that starts up the+system that explores a tree in parallel using the given tree (constructed+possibly using information supplied on the command line) and the given adapter+provided via the driver argument.++All of the functionality of this module can be accessed through 'genericMain',+but we nonetheless also provide specialized versions of these functions for all+of the supported tree purities and exploration modes. This is done for two+reasons: first, in order to make the types more concrete to hopefully improve+usability, and second, because often the type of the tree is generalized so it+could be one of several types, and using a specialized function automatically+specializes the type rather than requiring a type annotation. The convention is+@mainForExploreTreeXY@ where @X@ is empty for pure trees, @IO@ for trees with+side-effects in the `IO` monad, and @Impure@ for trees with side-effects in some+general monad, and @Y@ specifies the exploration mode, which is empty for+'AllMode' (sum over all results), @UntilFirst@ for 'FirstMode' (stop when first+result found), @UntilFoundUsingPull@ for 'FoundModeUsingPull' (sum all results+until a condition has been met, only sending results to the supervisor upon+request) and @UntilFoundUsingPush@ for 'FoundModeUsingPush' (sum all results+until a condition has been met, pushing all found results immediately to the+supervisor).++If you do not need to use command-line arguments to construct the tree and don't+care about what the name of the program is on the help screen then you might be+interested in the simpler version of these functions in the following section+(follow "LogicGrowsOnTrees.Parallel.Main#main-simple").+ -}+ +---------------------------- Sum over all results ------------------------------++{- $all #all#+The functions in this section are for when you want to sum over all the results+in (the leaves of) the tree.+ -}++{-| Explore the given pure tree in parallel; the results in the leaves will be+    summed up using the 'Monoid' instance.+ -}+mainForExploreTree ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration Identity IO (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTree = genericMain (const AllMode) Pure++{-| Explore the given IO tree in parallel; the results in the leaves will be+    summed up using the 'Monoid' instance.+ -}+mainForExploreTreeIO ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration IO IO (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeIO = genericMain (const AllMode) io_purity++{-| Explore the given impure tree in parallel; the results in all of the leaves+    will be summed up using the 'Monoid' instance.+ -}+mainForExploreTreeImpure ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration m m (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeImpure = genericMain (const AllMode) . ImpureAtopIO++---------------------------- Stop at first result ------------------------------++{- $first #first#+The functions in this section are for when you want to stop as soon as you have+found a result.++There are two ways in which a system running in this mode can terminate normally:++    1. A solution is found, in which case a 'Just'-wrapped value is returned+       with both the found solution and the current 'Checkpoint', the latter+       allowing one to resume the search to look for more solutions later.++    2. The whole tree has been explored, in which case 'Nothing' is returned.++ -}++{-| Explore the given pure tree in parallel, stopping if a solution is found. -}+mainForExploreTreeUntilFirst ::+    (Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration Identity IO (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeUntilFirst = genericMain (const FirstMode) Pure++{-| Explore the given IO tree in parallel, stopping if a solution is found. -}+mainForExploreTreeIOUntilFirst ::+    (Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration IO IO (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeIOUntilFirst = genericMain (const FirstMode) io_purity++{-| Explore the given impure tree in parallel, stopping if a solution is found. -}+mainForExploreTreeImpureUntilFirst ::+    (Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration m m (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeImpureUntilFirst = genericMain (const FirstMode) . ImpureAtopIO++------------------- Stop when sum of results meets condition -------------------++{- $found #found#+The functions in this section are for when you want sum the results as you find+them until the sum matches a condition.  There are two versions of this mode,+based on whether one wants to regularly poll the workers for results or whether+one wants workers to immediately push every result to the supervisor as soon as+it is found.+ -}++{- $pull #pull#+In this mode, partial results are left on the workers until they receive either+a workload steal request or a progress update request. The advantage of this+approach is that it minimizes communication costs as partial results are sent on+an occasional basis rather than as soon as they are found. The downside of this+approach is that one has to poll the workers on a regular basis using a global+process update, and between polls it might be the case that the sum of all+results in the system meets the condition but this will not be found out until+the next poll, which wastes time equal to the amount of time between polls. If+you would rather have the system immediately terminate as soon as it has found+the desired results (at the price of paying an additional cost as each workload+is found in sending it to the supervisor), then follow+"LogicGrowsOnTrees.Parallel.Main#push" to see the description of push mode.++There are three ways in which a system running in this mode can terminate:++    1. A worker finds another result and now its (new) local sum meet the+       condition; in this case the sum of the worker's local sum and the+       supervisor's local sum is returned along with the current checkpoint+       (which allows the search to be resumed later to find more results), all+       wrapped in a 'Right'.++    2. The supervisor, having just received some new results from a worker, has+       its (new) local sum meet the condition; this has essentially the same+       effect as 1.++    3. The tree has been fully explored, in which case the full sum is returned+       in a 'Left'.++WARNING:  If you use this mode then you need to enable checkpointing when the+          program is run; if you do not do this, then you might end up in a+          situation where the sum of results over the entire system meets the+          condition but the system does not realize this because the results+          have not been gathered together and summed at the supervisor.+ -}++{-| Explore the given pure tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration Identity IO (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) Pure++{-| Explore the given IO tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeIOUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration IO IO (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeIOUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) io_purity++{-| Explore the given impure tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeImpureUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration m m (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeImpureUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) . ImpureAtopIO++{- $push #push#+In this mode, whenever a result is found it is immediately sent to the+supervisor. The advantage of this approach is that the system finds out+immediately when all the results found so far have met the condition, rather+than waiting for a progress update to occur that gathers them together. The+downside of this approach is that it costs some time for a worker to send a+result to the supervisor, so if the condition will not be met until a large+number of results have been found then it be better let the workers accumulate+results locally and to poll them on a regular basis; to do this, follow+"LogicGrowsOnTrees.Parallel.Main#pull" to see the description of pull mode.++There are three ways in which a system running in this mode can terminate:++    1. The supervisor, having just received a new result from a worker, finds+       that its current sum meets the condition function, in which case it+       returns the sum as well as the current checkpoint (which allows the+       search to be resumed later to find more results) wrapped in a 'Right'.++    2. The tree has been fully explored, in which case the full sum is returned+       in a 'Left'.++(Note that, unlike the pull version, a partial result will not be returned upon+success as the Supervisor has access to all results and so it will never be in+the position of only having a partial result upon success.)+ -}++{-| Explore the given pure tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration Identity IO (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) Pure++{-| Explore the given IO tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeIOUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration IO IO (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeIOUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) io_purity++{-| Explore the given impure tree in parallel until the sum of results meets the+    given condition.+ -}+mainForExploreTreeImpureUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (tree_configuration → result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration tree_configuration) SupervisorConfiguration m m (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+mainForExploreTreeImpureUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) . ImpureAtopIO++---------------------------- Generic main function -----------------------------++{-| This is just like the previous functions, except that it is generalized over+    all tree purities and exploration modes.  (In fact, the specialized+    functions are just wrappers around this function.)+ -}+genericMain ::+    ( MonadIO result_monad+    , ResultFor exploration_mode ~ result+    , Serialize (ProgressFor exploration_mode)+    ) ⇒+    (tree_configuration → ExplorationMode exploration_mode)+        {-^ a function that constructs the exploration mode given the tree+            configuration; note that the constructor that this function returns+            is restricted by the value of the exploration_mode type variable+         -} →+    Purity m n {-^ the purity of the tree -} →+    Driver+        result_monad+        (SharedConfiguration tree_configuration)+        SupervisorConfiguration+        m n+        exploration_mode+        {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} →+    TermInfo+        {-^ information about the program; should look something like the following:++                > defTI { termDoc = "count the number of n-queens solutions for a given board size" }+         -} →+    (tree_configuration → RunOutcomeFor exploration_mode → IO ())+        {-^ a callback that will be invoked with the outcome of the run and the+            tree configuration information; note that if the run was 'Completed'+            then the checkpoint file will be deleted if this function finishes+            successfully+         -} →+    (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} →+    result_monad ()+genericMain constructExplorationMode_ purity (Driver run) tree_configuration_term program_info notifyTerminated_ constructTree_ =+    run DriverParameters{..}+  where+    constructExplorationMode = constructExplorationMode_ . tree_configuration+    shared_configuration_term = makeSharedConfigurationTerm tree_configuration_term+    supervisor_configuration_term =+        SupervisorConfiguration+            <$> checkpoint_configuration_term+            <*> maybe_workload_buffer_size_configuration_term+            <*> statistics_configuration_term+    initializeGlobalState SharedConfiguration{logging_configuration=LoggingConfiguration{..}} =+        updateGlobalLogger rootLoggerName (setLevel log_level)+    constructTree = constructTree_ . tree_configuration+    getStartingProgress shared_configuration SupervisorConfiguration{..} =+        case maybe_checkpoint_configuration of+            Nothing → (infoM "Checkpointing is NOT enabled") >> return initial_progress+            Just CheckpointConfiguration{..} → do+                noticeM $ "Checkpointing enabled"+                noticeM $ "Checkpoint file is " ++ checkpoint_path+                noticeM $ "Checkpoint interval is " ++ show checkpoint_interval ++ " seconds"+                ifM (doesFileExist checkpoint_path)+                    (noticeM "Loading existing checkpoint file" >> either error id . decodeLazy <$> readFile checkpoint_path)+                    (return initial_progress)+      where+        initial_progress = initialProgress . constructExplorationMode $ shared_configuration+    notifyTerminated SharedConfiguration{..} SupervisorConfiguration{..} run_outcome@RunOutcome{..} =+        case maybe_checkpoint_configuration of+            Nothing → doEndOfRun+            Just CheckpointConfiguration{checkpoint_path} →+                do doEndOfRun+                   noticeM "Deleting any remaining checkpoint file"+                   removeFileIfExists checkpoint_path+                `finally`+                case runTerminationReason of+                    Aborted checkpoint → writeCheckpointFile checkpoint_path checkpoint+                    Failure checkpoint _ → writeCheckpointFile checkpoint_path checkpoint+                    _ → return ()+      where+        doEndOfRun = do+            showStatistics statistics_configuration runStatistics+            notifyTerminated_ tree_configuration run_outcome++    constructController = const controllerLoop++--------------------------------------------------------------------------------+-------------------------- Simplified main functions ---------------------------+--------------------------------------------------------------------------------++{- $main-simple #main-simple#+The functions in this section provide simpler version of the functions in the+preceding section (follow "LogicGrowsOnTrees.Parallel.Main#main") for the case+where you do not need to use command-line arguments to construct the tree and+don't care about what the name of the program is on the help screen; the naming+convention follows the same convention as that in the previous section.+ -}++---------------------------- Sum over all results ------------------------------++{- $all-simple+The functions in this section are for when you want to sum over all the results+in (the leaves of) the tree.+ -}++{-| Explore the given pure tree in parallel; the results+    in the leaves will be summed up using the 'Monoid' instance.+ -}+simpleMainForExploreTree ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration Identity IO (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    Tree result {-^ the tree to explore -} →+    result_monad ()+simpleMainForExploreTree = dispatchToMainFunction mainForExploreTree++{-| Explore the given IO tree in parallel;+    the results in the leaves will be summed up using the 'Monoid' instance.+ -}+simpleMainForExploreTreeIO ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration IO IO (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeIO result {-^ the tree to explore in IO -} →+    result_monad ()+simpleMainForExploreTreeIO = dispatchToMainFunction mainForExploreTreeIO++{-| Explore the given impure tree in parallel; the+    results in all of the leaves will be summed up using the 'Monoid' instance.+ -}+simpleMainForExploreTreeImpure ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration m m (AllMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) result → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeT m result {-^ the (impure) tree to explore -} →+    result_monad ()+simpleMainForExploreTreeImpure = dispatchToMainFunction . mainForExploreTreeImpure++---------------------------- Stop at first result ------------------------------++{- $first-simple+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#first"+ -}++{-| Explore the given pure tree in parallel, stopping if a solution is found. -}+simpleMainForExploreTreeUntilFirst ::+    (Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration Identity IO (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    Tree result {-^ the tree to explore -} →+    result_monad ()+simpleMainForExploreTreeUntilFirst = dispatchToMainFunction mainForExploreTreeUntilFirst++{-| Explore the given tree in parallel in IO, stopping if a solution is found. -}+simpleMainForExploreTreeIOUntilFirst ::+    (Serialize result, MonadIO result_monad) ⇒+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration IO IO (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeIO result {-^ the tree to explore in IO -} →+    result_monad ()+simpleMainForExploreTreeIOUntilFirst = dispatchToMainFunction mainForExploreTreeIOUntilFirst++{-| Explore the given impure tree in parallel, stopping if a solution is found. -}+simpleMainForExploreTreeImpureUntilFirst ::+    (Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration m m (FirstMode result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome Checkpoint (Maybe (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeT m result {-^ the impure tree to explore -} →+    result_monad ()+simpleMainForExploreTreeImpureUntilFirst = dispatchToMainFunction . mainForExploreTreeImpureUntilFirst++------------------- Stop when sum of results meets condition -------------------++{- $found-simple+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#found"+ -}++{- $pull-simple+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#pull"+ -}++{-| Explore the given pure tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration Identity IO (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    Tree result {-^ the tree to explore -} →+    result_monad ()+simpleMainForExploreTreeUntilFoundUsingPull = dispatchToMainFunction . mainForExploreTreeUntilFoundUsingPull . const++{-| Explore the given IO tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeIOUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration IO IO (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeIO result {-^ the tree to explore in IO -} →+    result_monad ()+simpleMainForExploreTreeIOUntilFoundUsingPull = dispatchToMainFunction . mainForExploreTreeIOUntilFoundUsingPull . const++{-| Explore the given impure tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeImpureUntilFoundUsingPull ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration m m (FoundModeUsingPull result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeT m result {-^ the impure tree to explore -} →+    result_monad ()+simpleMainForExploreTreeImpureUntilFoundUsingPull = (dispatchToMainFunction .* mainForExploreTreeImpureUntilFoundUsingPull) . const++{- $push-simple+For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#push"+ -}++{-| Explore the given pure tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration Identity IO (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →++    Tree result {-^ the tree to explore -} →+    result_monad ()+simpleMainForExploreTreeUntilFoundUsingPush = dispatchToMainFunction . mainForExploreTreeUntilFoundUsingPush . const++{-| Explore the given IO tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeIOUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration IO IO (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeIO result {-^ the tree to explore in IO -} →+    result_monad ()+simpleMainForExploreTreeIOUntilFoundUsingPush = dispatchToMainFunction . mainForExploreTreeIOUntilFoundUsingPush . const++{-| Explore the given impure tree in parallel until the sum of results meets the+    given condition.+ -}+simpleMainForExploreTreeImpureUntilFoundUsingPush ::+    (Monoid result, Serialize result, MonadIO result_monad, Functor m, MonadIO m) ⇒+    (result → Bool) {-^ a condition function that signals when we have found all of the result that we wanted -} →+    (∀ β. m β → IO β) {-^ a function that runs an @m@ action in the 'IO' monad -} →+    Driver result_monad (SharedConfiguration ()) SupervisorConfiguration m m (FoundModeUsingPush result) {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} →+    (RunOutcome (Progress result) (Either result (Progress result)) → IO ())+        {-^ a callback that will be invoked with the outcome of the run; note+            that if the run was 'Completed' then the checkpoint file will be+            deleted if this function finishes successfully+         -} →+    TreeT m result {-^ the impure tree to explore -} →+    result_monad ()+simpleMainForExploreTreeImpureUntilFoundUsingPush = (dispatchToMainFunction .* mainForExploreTreeImpureUntilFoundUsingPush) . const++--------------------------------------------------------------------------------+------------------------------ Utility functions -------------------------------+--------------------------------------------------------------------------------++{-| Converts a 'SupervisorOutcome' to a 'RunOutcome'. -}+extractRunOutcomeFromSupervisorOutcome ::+    Show worker_id ⇒+    SupervisorOutcome fv ip worker_id →+    RunOutcome ip fv+extractRunOutcomeFromSupervisorOutcome SupervisorOutcome{..} = RunOutcome{..}+  where+    runTerminationReason =+        case supervisorTerminationReason of+            SupervisorAborted remaining_progress → Aborted remaining_progress+            SupervisorCompleted result → Completed result+            SupervisorFailure remainig_progress worker_id message →+                Failure remainig_progress $ "Worker " ++ show worker_id ++ " failed with message: " ++ message+    runStatistics = supervisorRunStatistics++{-| Parse the command line options using the given term and term info (the+    latter of which has the program name added to it);  if successful return the+    result, otherwise throw an exception.+ -}+mainParser :: Term α → TermInfo → IO α+mainParser term term_info =+    (if null (termName term_info)+        then getProgName >>= \progname → return $ term_info {termName = progname}+        else return term_info+    ) >>= exec . (term,)++--------------------------------------------------------------------------------+----------------------------------- Internal -----------------------------------+--------------------------------------------------------------------------------++default_terminfo :: TermInfo+default_terminfo = defTI { termDoc = "LogicGrowsOnTrees program" }++dispatchToMainFunction f driver notifyTerminated tree =+    f   driver+        (pure ())+        default_terminfo+        (const notifyTerminated)+        (const tree)+{- INLINE dispatchToMainFunction -}++checkpoint_configuration_term :: Term (Maybe CheckpointConfiguration)+checkpoint_configuration_term =+    maybe (const Nothing) (Just .* CheckpointConfiguration)+        <$> value (flip opt (+            (optInfo ["c","checkpoint-file"])+            {   optName = "FILEPATH"+            ,   optDoc = "This enables periodic checkpointing with the given path specifying the location of the checkpoint file;  if the file already exists then it will be loaded as the initial starting point for the search."+            }+            ) Nothing)+        <*> value (flip opt (+            (optInfo ["i","checkpoint-interval"])+            {   optName = "SECONDS"+            ,   optDoc = "This specifies the time between checkpoints (in seconds, decimals allowed); it is ignored if checkpoint file is not specified."+            }+            ) 60)++logging_configuration_term :: Term LoggingConfiguration+logging_configuration_term =+    LoggingConfiguration+    <$> value (flip opt (+        (optInfo ["l","log-level"])+        {   optName = "LEVEL"+        ,   optDoc = "This specifies the upper bound (inclusive) on the importance of the messages that will be logged;  it must be one of (in increasing order of importance): DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, or EMERGENCY."+        }+        ) WARNING)++statistics_configuration_term :: Term StatisticsConfiguration+statistics_configuration_term =+    (\show_all → if show_all then const (StatisticsConfiguration True True True True True True True True True True True) else id)+    <$> value (flag ((optInfo ["show-all"]) { optDoc ="This option will cause *all* run statistic to be printed to standard error after the program terminates." }))+    <*> (StatisticsConfiguration+        <$> value (flag ((optInfo ["show-walltimes"]) { optDoc ="This option will cause the starting, ending, and duration wall time of the run to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-supervisor-occupation"]) { optDoc ="This option will cause the supervisor occupation percentage to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-supervisor-monad-occupation"]) { optDoc ="This option will cause the supervisor monad occupation percentage to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-supervisor-calls"]) { optDoc ="This option will cause the number of supervisor calls and average time per supervisor call to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-worker-occupation"]) { optDoc ="This option will cause the worker occupation percentage to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-worker-wait-times"]) { optDoc ="This option will cause statistics about the worker wait times to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-steal-wait-times"]) { optDoc ="This option will cause statistics about the steal wait times to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-numbers-of-waiting-workers"]) { optDoc ="This option will cause statistics about the number of waiting workers to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-numbers-of-available-workloads"]) { optDoc ="This option will cause statistics about the number of available workloads to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-workload-request-rate"]) { optDoc ="This option will cause statistics about the (roughly) instantaneous rate at which workloads are requested by finished works to be printed to standard error after the program terminates." }))+        <*> value (flag ((optInfo ["show-workload-steal-time"]) { optDoc ="This option will cause statistics about the (roughly) instantaneous amount of time that it took to steal a workload to be printed to standard error after the program terminates." }))+        )++maybe_workload_buffer_size_configuration_term :: Term (Maybe Int)+maybe_workload_buffer_size_configuration_term =+    value (opt Nothing ((optInfo ["buffer-size"]) { optName = "SIZE", optDoc = "This option sets the size of the workload buffer, which contains stolen workloads that are held at the supervisor so that if a worker needs a new workload it can be given one immediately rather than having to wait for a new workload to be stolen.  This setting should be large enough that a request for a new workload can always be answered immediately using a workload from the buffer, which is roughly a function of the product of the number of workloads requested per second and the time needed to steal a new workload (both of which are server statistics than you can request to see upon completions).  If you are not having problems with scaling, then you can ignore this option (it defaults to 4)." }))++makeSharedConfigurationTerm :: Term tree_configuration → Term (SharedConfiguration tree_configuration)+makeSharedConfigurationTerm tree_configuration_term =+    SharedConfiguration+        <$> logging_configuration_term+        <*> tree_configuration_term++checkpointLoop ::+    ( RequestQueueMonad m+    , Serialize (ProgressFor (ExplorationModeFor m))+    ) ⇒ CheckpointConfiguration → m α+checkpointLoop CheckpointConfiguration{..} = forever $ do+    liftIO $ threadDelay delay+    requestProgressUpdate >>= writeCheckpointFile checkpoint_path+  where+    delay = round $ checkpoint_interval * 1000000++controllerLoop ::+    ( RequestQueueMonad m+    , Serialize (ProgressFor (ExplorationModeFor m))+    ) ⇒ SupervisorConfiguration → m ()+controllerLoop SupervisorConfiguration{..} = do+    maybe (return ()) setWorkloadBufferSize $ maybe_workload_buffer_size_configuration+    maybe_checkpoint_thread_id ← maybeForkIO checkpointLoop maybe_checkpoint_configuration+    case catMaybes+        [maybe_checkpoint_thread_id+        ]+     of [] → return ()+        thread_ids → liftIO $+            (forever $ threadDelay 3600000000)+            `finally`+            (mapM_ killThread thread_ids)++maybeForkIO :: RequestQueueMonad m ⇒ (α → m ()) → Maybe α → m (Maybe ThreadId)+maybeForkIO loop = maybe (return Nothing) (liftM Just . fork . loop)++removeFileIfExists :: FilePath → IO ()+removeFileIfExists path =+    handleJust+        (\e → if isDoesNotExistError e then Nothing else Just ())+        (\_ → return ())+        (removeFile path)++showStatistics :: MonadIO m ⇒ StatisticsConfiguration → RunStatistics → m ()+showStatistics StatisticsConfiguration{..} RunStatistics{..} = liftIO $ do+    let total_time :: Double+        total_time = realToFrac runWallTime+    when show_wall_times $+        hPutStrLn stderr $+            printf "Run started at %s, ended at %s, and took %sseconds.\n"+                (show runStartTime)+                (show runEndTime)+                (showWithUnitPrefix total_time)+    hPutStr stderr $+        case (show_supervisor_occupation,show_supervisor_monad_occupation) of+            (True,False) → printf "Supervior was occupied for %.2f%% of the run.\n\n" (runSupervisorOccupation*100)+            (False,True) → printf "Supervisor ran inside the SupervisorMonad for %.2f%% of the run.\n\n" (runSupervisorMonadOccupation*100)+            (True,True) → printf "Supervior was occupied for %.2f%% of the run, of which %.2f%% was spent inside the SupervisorMonad.\n\n" (runSupervisorOccupation*100) (runSupervisorOccupation/runSupervisorMonadOccupation*100)+            _ → ""+    when show_supervisor_calls $+        hPutStrLn stderr $+            printf "%i calls were made into the supervisor monad, and each took an average of %sseconds.\n"+                runNumberOfCalls+                (showWithUnitPrefix runAverageTimePerCall)+    when show_worker_occupation $+        hPutStrLn stderr $+            printf "Workers were occupied %.2f%% of the time on average.\n"+                (runWorkerOccupation*100)+    when show_worker_wait_times $ do+        let FunctionOfTimeStatistics{..} = runWorkerWaitTimes+        hPutStrLn stderr $+          if timeCount == 0+            then+              "At no point did a worker receive a new workload after finishing a workload."+            else+              if timeMax == 0+                then+                  printf "Workers completed their task and obtained a new workload %i times and never had to wait to receive the new workload."+                    timeCount+                else+                  printf+                    (unlines+                        ["Workers completed their task and obtained a new workload %i times with an average of one every %sseconds or %.1g enqueues/second."+                        ,"The minimum waiting time was %sseconds, and the maximum waiting time was %sseconds."+                        ,"On average, a worker had to wait %sseconds +/- %sseconds (std. dev) for a new workload."+                        ]+                    )+                    timeCount+                    (showWithUnitPrefix $ total_time / fromIntegral timeCount)+                    (fromIntegral timeCount / total_time)+                    (showWithUnitPrefix timeMin)+                    (showWithUnitPrefix timeMax)+                    (showWithUnitPrefix timeAverage)+                    (showWithUnitPrefix timeStdDev)+    when show_steal_wait_times $ do+        let IndependentMeasurementsStatistics{..} = runStealWaitTimes+        hPutStrLn stderr $+          if statCount == 0+            then+              "No workloads were stolen."+            else+              printf+                (unlines+                    ["Workloads were stolen %i times with an average of %sseconds between each steal or %.1g steals/second."+                    ,"The minimum waiting time for a steal was %sseconds, and the maximum waiting time was %sseconds."+                    ,"On average, it took %sseconds +/- %sseconds (std. dev) to steal a workload."+                    ]+                )+                statCount+                (showWithUnitPrefix $ total_time / fromIntegral statCount)+                (fromIntegral statCount / total_time)+                (showWithUnitPrefix statMin)+                (showWithUnitPrefix statMax)+                (showWithUnitPrefix statAverage)+                (showWithUnitPrefix statStdDev)+    when show_numbers_of_waiting_workers $ do+        let FunctionOfTimeStatistics{..} = runWaitingWorkerStatistics+        hPutStrLn stderr $+          if timeMax == 0+            then+              printf "No worker ever had to wait for a workload to become available.\n"+            else if timeMin == 0+              then+                printf "On average, %.1f +/ - %.1f (std. dev) workers were waiting at any given time;  never more than %i.\n"+                  timeAverage+                  timeStdDev+                  timeMax+              else+                printf "On average, %.1f +/ - %.1f (std. dev) workers were waiting at any given time;  never more than %i nor fewer than %i.\n"+                  timeAverage+                  timeStdDev+                  timeMax+                  timeMin+    when show_numbers_of_available_workloads $ do+        let FunctionOfTimeStatistics{..} = runAvailableWorkloadStatistics+        hPutStrLn stderr $+          if timeMax == 0+            then+              printf "No workload ever had to wait for an available worker.\n"+            else if timeMin == 0+              then+                printf "On average, %.1f +/ - %.1f (std. dev) workloads were waiting for a worker at any given time;  never more than %i.\n"+                  timeAverage+                  timeStdDev+                  timeMax+              else+                printf "On average, %.1f +/ - %.1f (std. dev) workloads were waiting for a worker at any given time;  never more than %i nor fewer than %i.\n"+                  timeAverage+                  timeStdDev+                  timeMax+                  timeMin+    when show_instantaneous_workload_request_rates $ do+        let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadRequestRateStatistics+        hPutStrLn stderr $+            printf+                (unlines+                    ["On average, the instantanenous rate at which workloads were being requested was %.1f +/ - %.1f (std. dev) requests per second;  the rate never fell below %.1f nor rose above %.1f."+                    ,"This value was obtained by exponentially smoothing the request data over a time scale of one second."+                    ]+                )+                timeAverage+                timeStdDev+                timeMin+                timeMax+    when show_instantaneous_workload_steal_times $ do+        let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadStealTimeStatistics+        hPutStrLn stderr $+            printf+                (unlines+                    ["On average, the instantaneous time to steal a workload was %sseconds +/ - %sseconds (std. dev);  this time interval never fell below %sseconds nor rose above %sseconds."+                    ,"This value was obtained by exponentially smoothing the request data over a time scale of one second."+                    ]+                )+                (showWithUnitPrefix timeAverage)+                (showWithUnitPrefix timeStdDev)+                (showWithUnitPrefix timeMin)+                (showWithUnitPrefix timeMax)+  where+    showWithUnitPrefix :: Real n ⇒ n → String+    showWithUnitPrefix 0 = "0 "+    showWithUnitPrefix x = printf "%.1f %s" x_scaled (unitName unit)+      where+        (x_scaled :: Float,Just unit) = formatValue (Left FormatSiAll) . realToFrac $ x++writeCheckpointFile :: (Serialize ip, MonadIO m) ⇒ FilePath → ip → m ()+writeCheckpointFile checkpoint_path checkpoint = do+    noticeM $ "Writing checkpoint file"+    liftIO $+        (do writeFile checkpoint_temp_path (encodeLazy checkpoint)+            renameFile checkpoint_temp_path checkpoint_path+        ) `onException` (+            removeFileIfExists checkpoint_temp_path+        )+  where+    checkpoint_temp_path = checkpoint_path ++ ".tmp"
+ sources/LogicGrowsOnTrees/Parallel/Purity.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains types that represent the purity of a tree, which is+    either pure, impure, or IO (a special case of impure).+ -}+module LogicGrowsOnTrees.Parallel.Purity+    ( Purity(..)+    , io_purity+    ) where++import Control.Monad.IO.Class++import Data.Functor.Identity (Identity)++{-| The purity of a tree, which can be either 'Pure' (for pure trees) or+    'ImpureAtopIO' (for impure trees); the latter case is restricted to monads+    that are instances of 'MonadIO' and for which there exists a way to convert+    the monad into an IO action.++    The two kind arguments, @m@ and @n@, correspond to respectively the monad in+    on top of which the 'TreeT' monad transformer is stacked and the monad in+    which the worker will be run.+ -} +data Purity (m :: * → *) (n :: * → *) where -- {{{+    Pure :: Purity Identity IO+    ImpureAtopIO :: MonadIO m ⇒ (∀ β. m β → IO β) → Purity m m++{-| The purity of trees in the IO monad. -}+io_purity :: Purity IO IO+io_purity = ImpureAtopIO id
+ sources/LogicGrowsOnTrees/Path.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This modules contains functionality relating to paths through trees. -}+module LogicGrowsOnTrees.Path+    (+    -- * Types+      BranchChoice(..)+    , Step(..)+    , Path+    -- * Functions+    , oppositeBranchChoiceOf+    , sendTreeDownPath+    , sendTreeTDownPath+    -- * Exceptions+    , WalkError(..)+    ) where++import Control.Exception (Exception(),throw)+import Control.Monad.Operational (ProgramViewT(..),viewT)++import Data.ByteString (ByteString)+import Data.Derive.Serialize+import Data.DeriveTH+import Data.Functor.Identity (runIdentity)+import Data.Sequence (Seq,viewl,ViewL(..))+import Data.Serialize+import Data.Typeable (Typeable)++import LogicGrowsOnTrees++--------------------------------------------------------------------------------+---------------------------------- Exceptions ----------------------------------+--------------------------------------------------------------------------------++{-| This exception is thrown whenever a 'Tree' is sent down a path which+    is incompatible with it.+ -}+data WalkError =+    {-| Indicates that a path is too long for a given tree --- that is, the walk+        hit a leaf (or a null) before the end of the path was reached.+     -}+    TreeEndedBeforeEndOfWalk+    {-| Indicates that a choice step in a path coincided with a cache point in+        a tree, or vice versa.+     -}+  | PastTreeIsInconsistentWithPresentTree+  deriving (Eq,Show,Typeable)++instance Exception WalkError++--------------------------------------------------------------------------------+------------------------------------- Types ------------------------------------+--------------------------------------------------------------------------------++{-| A choice at a branch point to take either the left branch or the right branch. -}+data BranchChoice =+    LeftBranch+  | RightBranch+  deriving (Eq,Ord,Read,Show)+$( derive makeSerialize ''BranchChoice )++{-| A step in a path through a tree, which can either pass through a point with+    a cached result or take a choice to go left or right at a branch point.+ -}+data Step =+    CacheStep ByteString {-^ Step through a cache point -}+ |  ChoiceStep BranchChoice {-^ Step through a choice point -}+ deriving (Eq,Ord,Show)+$( derive makeSerialize ''Step )++{-| A sequence of 'Step's. -}+type Path = Seq Step++--------------------------------------------------------------------------------+---------------------------------- Functions -----------------------------------+--------------------------------------------------------------------------------++{-| Returns the opposite of the given branch choice. -}+oppositeBranchChoiceOf :: BranchChoice → BranchChoice+oppositeBranchChoiceOf LeftBranch = RightBranch+oppositeBranchChoiceOf RightBranch = LeftBranch++{-| Follows a 'Path' through a 'Tree' to a particular subtree;  the+    main use case of this function is for a processor which has been given a+    particular subtree as its workload to zoom in on that subtree. The way this+    function works is as follows: as long as the remaining path is non-empty, it+    explores the 'Tree' until it encounters either a cache point or a choice+    point; in the former case the path supplies the cached value in the+    'CacheStep' constructor, and in the latter case the path supplies the branch+    to take in the 'ChoiceStep' constructor; when the remaining path is empty+    then the resulting 'Tree' is returned.++    WARNING: This function is /not/ valid for all inputs; it makes the+    assumption that the given 'Path' has been derived from the given 'Tree' so+    that the path will always encountered choice points exactly when the tree+    does and likewise for cache points. Furthermore, the path must not run out+    before the tree hits a leaf. If any of these conditions is violated, a+    'WalkError' exception will be thrown; in fact, you should hope than+    exception is thrown because it will let you know that there is a bug your+    code as the alternative is that you accidently give it a path that is not+    derived from the given tree but which coincidentally matches it which means+    that it will silently return a nonsensical result. Having said all that, you+    should almost never need to worry about this possibility in practice because+    there will normally be only one tree in use at a time and all paths in use+    will have come from that tree.+ -}+sendTreeDownPath :: Path → Tree α → Tree α+sendTreeDownPath path = runIdentity . sendTreeTDownPath path++{-| Like 'sendTreeDownPath', but for impure trees. -}+sendTreeTDownPath :: Monad m ⇒ Path → TreeT m α → m (TreeT m α)+sendTreeTDownPath path tree =+    case viewl path of+        EmptyL → return tree+        step :< tail → do+            view ← viewT . unwrapTreeT $ tree+            case (view,step) of+                (Return _,_) →+                    throw TreeEndedBeforeEndOfWalk+                (Null :>>= _,_) →+                    throw TreeEndedBeforeEndOfWalk+                (Cache _ :>>= k,CacheStep cache) →+                    sendTreeTDownPath tail $ either error (TreeT . k) (decode cache)+                (Choice left _ :>>= k,ChoiceStep LeftBranch) →+                    sendTreeTDownPath tail (left >>= TreeT . k)+                (Choice _ right :>>= k,ChoiceStep RightBranch) →+                    sendTreeTDownPath tail (right >>= TreeT . k)+                (ProcessPendingRequests :>>= k,_) →+                    sendTreeTDownPath path (TreeT . k $ ())+                _ → throw PastTreeIsInconsistentWithPresentTree
+ sources/LogicGrowsOnTrees/Utils/Handle.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains a couple of utility functions for sending and receiving+    'Serialize'-able data over a handle. Because the size of the serialized+    value can depend on the value being sent, these functions employ a protocol+    in which first the size of the serialized data is sent as a 64-bit+    big-endian word, and then the serialized data itself is sent.+ -}+module LogicGrowsOnTrees.Utils.Handle+    (+    -- * Exceptions+      ConnectionLost(..)+    -- * Functions+    , filterEOFExceptions+    , receive+    , send+    ) where++import Prelude hiding (catch)++import Control.Exception (Exception,catch,throwIO)+import Control.Monad (unless)++import qualified Data.ByteString as BS+import Data.ByteString (hGet,hPut)+import Data.Serialize (Serialize,encode,decode,runGet,runPut,getWord64be,putWord64be)+import Data.Typeable (Typeable)++import System.IO (Handle,hFlush)+import System.IO.Error (isEOFError,ioeGetErrorType)++--------------------------------------------------------------------------------+---------------------------------- Exceptions ----------------------------------+--------------------------------------------------------------------------------++{-| This exception is thrown when the connection has been lost. -}+data ConnectionLost = ConnectionLost+  deriving (Show,Typeable)+instance Exception ConnectionLost++{-| Replaces EOF 'IOException's with the 'ConnectionLost' exception. -}+filterEOFExceptions = flip catch $+    \e → if isEOFError e || (show . ioeGetErrorType $ e) == "resource vanished"+        then throwIO ConnectionLost+        else throwIO e++{-| Receives a 'Serialize'-able value from a handle.++    Specifically, this function reads in a 64-bit big-endian word with the+    size of the raw data to be read, reads that much data in bytes into a+    'ByteString', and then deserializes the 'ByteString' to produce the+    resulting value.++    If the connection has been lost, it throws 'ConnectionLost'.+ -}+receive :: Serialize α ⇒ Handle → IO α+receive handle = filterEOFExceptions $ do+    size_bytes ← hGet handle 8+    unless (BS.length size_bytes == 8) $ throwIO ConnectionLost+    let number_of_value_bytes =+            either error fromIntegral+            .+            runGet getWord64be+            $+            size_bytes+    value_bytes ← hGet handle number_of_value_bytes+    unless (BS.length value_bytes == number_of_value_bytes) $ throwIO ConnectionLost+    return . either error id . decode $ value_bytes++{-| Sends a 'Serialize'-able value to a handle.++    Specifically, this function serializes the given value to a 'ByteString',+    and then writes the size of the serialized data in bytes as a 64-bit+    big-endian word followed by the raw data itself.++    If the connection has been lost, it throws 'ConnectionLost'.+ -}+send :: Serialize α ⇒ Handle → α → IO ()+send handle value = filterEOFExceptions $ do+    let encoded_value = encode value+    hPut handle . runPut . putWord64be . fromIntegral . BS.length $ encoded_value+    hPut handle encoded_value+    hFlush handle
+ sources/LogicGrowsOnTrees/Utils/IntSum.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains a type that specializes the 'Sum' 'Monoid' to 'Int'. -}+module LogicGrowsOnTrees.Utils.IntSum where++import Data.List (foldl')+import Data.Monoid (Monoid(..))+import Data.Serialize (Serialize(..))+import Data.Typeable (Typeable)++{-| An unpacked 'Int' whose 'Monoid' instance is addition. -}+data IntSum = IntSum { getIntSum :: {-# UNPACK #-} !Int } deriving (Eq,Show,Typeable)++{-| This instance sums the two contained 'Int's. -}+instance Monoid IntSum where+    mempty = IntSum 0+    IntSum x `mappend` IntSum y = IntSum (x+y)+    mconcat = foldl' mappend mempty++{-| This instance is equivalent to the instance for 'Int'. -}+instance Serialize IntSum where+    put = put . getIntSum+    get = fmap IntSum get
+ sources/LogicGrowsOnTrees/Utils/PerfectTree.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This modules contains utility functions for constructing perfect trees for+    use in some of the tests and examples.+ -}+module LogicGrowsOnTrees.Utils.PerfectTree+    (+    -- * Tree generators+      perfectTree+    , trivialPerfectTree+    , numberOfLeaves+    -- * Arity and depth parameters+    , Arity(..)+    , ArityAndDepth(..)+    , makeArityAndDepthTermAtPositions+    , formArityAndDepth+    ) where++import Control.Applicative ((<$>),(<*>))+import Control.Monad (MonadPlus,msum)++import Data.List (genericReplicate)+import Data.Word (Word)++import System.Console.CmdTheLine++import Text.PrettyPrint (text)++import LogicGrowsOnTrees (Tree)+import LogicGrowsOnTrees.Utils.Word_+import LogicGrowsOnTrees.Utils.WordSum++--------------------------------------------------------------------------------+-------------------------- Arity and depth parameters --------------------------+--------------------------------------------------------------------------------++{-| Newtype wrapper for arities that has an 'ArgVal' instance that enforces that+    the arity be at least 2.+ -}+newtype Arity = Arity { getArity :: Word } deriving (Eq,Show)++instance ArgVal Arity where+    converter = (parseArity,prettyArity)+      where+        (parseWord_,prettyWord_) = converter+        parseArity =+            either Left (\(Word_ n) →+                if n >= 2+                    then Right . Arity $ n+                    else Left . text $ "tree arity must be at least 2 (not " ++ show n ++ ")"+            )+            .+            parseWord_+        prettyArity = prettyWord_ . Word_ . getArity+instance ArgVal (Maybe Arity) where+    converter = just++{-| Datatype representing the arity and depth of a tree, used for command line+    argument processing (see 'makeArityAndDepthTermAtPositions').+ -}+data ArityAndDepth = ArityAndDepth+    {   arity :: !Word+    ,   depth :: !Word+    } deriving (Eq, Show)++{-| Constructs a configuration term that expects the arity and depth to be at+    the given command line argument positions.+ -}+makeArityAndDepthTermAtPositions ::+    Int {-^ the position of the arity parameter in the command line -} →+    Int {-^ the position of the depth parameter in the command line -} →+    Term ArityAndDepth+makeArityAndDepthTermAtPositions arity_position depth_position =+    formArityAndDepth+    <$> (required $+         pos arity_position+             Nothing+             posInfo+               { posName = "ARITY"+               , posDoc = "tree arity"+               }+        )+    <*> (fmap getWord . required $+         pos depth_position+             Nothing+             posInfo+               { posName = "DEPTH"+               , posDoc = "tree depth (depth 0 means 1 level)"+               }+        )++{-| A convenience function used when you have an value of type 'Arity' for the+    arity of the tree rather than a value of type 'Word' and want to construct+    a value of type 'ArityAndDepth'.+ -}+formArityAndDepth :: Arity → Word → ArityAndDepth+formArityAndDepth (Arity arity) depth = ArityAndDepth{..}++--------------------------------------------------------------------------------+------------------------------- Tree generators --------------------------------+--------------------------------------------------------------------------------++{-| Generate a perfectly balanced tree with the given leaf value, arity, and leaf. -}+perfectTree ::+    MonadPlus m ⇒+    α {-^ the value to place at the leaves -} →+    Word {-^ the arity of the tree (i.e., number of branches at each internal node) -} →+    Word {-^ the depth of the tree -} →+    m α+perfectTree leaf arity depth+  | depth == 0 = return leaf+  | arity > 0  = msum . genericReplicate arity $ perfectTree leaf arity (depth-1)+  | otherwise  = error "arity must be a positive integer"+{-# SPECIALIZE perfectTree :: α → Word → Word → [α] #-}+{-# SPECIALIZE perfectTree :: α → Word → Word → Tree α #-}++{-| Like 'perfectTree' but with @WordSum 1@ at the leaves. -}+trivialPerfectTree ::+    MonadPlus m ⇒+    Word {-^ the arity of the tree (i.e., number of branches at each internal node) -} →+    Word {-^ the depth of the tree -} →+    m WordSum+trivialPerfectTree = perfectTree (WordSum 1)+{-# SPECIALIZE trivialPerfectTree :: Word → Word → [WordSum] #-}+{-# SPECIALIZE trivialPerfectTree :: Word → Word → Tree WordSum #-}++{-| Computes the number of leaves in a perfect tree.  It returns a value of type+    'Word' so that it can be easily compared to the 'WordSum' value returned by+    the tree generators, but a consequence of this is that it will overflow if+    the arity and/or depth arguments are too large.+ -}+numberOfLeaves ::+    Word {-^ the arity of the tree (i.e., number of branches at each internal node) -} →+    Word {-^ the depth of the tree -} →+    Word+numberOfLeaves arity depth = arity^depth
+ sources/LogicGrowsOnTrees/Utils/WordSum.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains a type that specializes the 'Sum' 'Monoid' to 'Word'. -}+module LogicGrowsOnTrees.Utils.WordSum where++import Data.List (foldl')+import Data.Monoid (Monoid(..))+import Data.Serialize (Serialize(..))+import Data.Typeable (Typeable)+import Data.Word (Word)++{-| An unpacked 'Word' whose 'Monoid' instance is addition. -}+data WordSum = WordSum { getWordSum :: {-# UNPACK #-} !Word } deriving (Eq,Show,Typeable)++{-| This instance sums the two contained 'Word's. -}+instance Monoid WordSum where+    mempty = WordSum 0+    WordSum x `mappend` WordSum y = WordSum (x+y)+    mconcat = foldl' mappend mempty++{-| This instance is equivalent to the instance for 'Word'. -}+instance Serialize WordSum where+    put = put . getWordSum+    get = fmap WordSum get+++
+ sources/LogicGrowsOnTrees/Utils/Word_.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module provides a temporary 'ArgVal' instance for 'Word' (via a newtype+    wrapper 'Word_') until 'cmdtheline' releases a new version that includes an+    'ArgVal' instance for 'Word' itself.+ -}+module LogicGrowsOnTrees.Utils.Word_ where++import Data.Word+import System.Console.CmdTheLine+import Text.PrettyPrint++{-| Newtype wrapper used to indirectly provide an 'ArgVal' instance for Word. -}+newtype Word_ = Word_ { getWord :: Word } deriving (Eq,Show)++instance ArgVal Word_ where+    converter = (parseWord,prettyWord)+      where+        (parseInt,prettyInt) = converter+        parseWord =+            either Left (\n →+                if n >= (0::Int)+                    then Right . Word_ . fromIntegral $ n+                    else Left . text $ "non-negative argument required (not " ++ show n ++ ")"+            )+            .+            parseInt+        prettyWord = prettyInt . fromIntegral . getWord++instance ArgVal (Maybe Word_) where+    converter = just
+ sources/LogicGrowsOnTrees/Workload.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}++{-| This module contains infrastructure for working with 'Workload's, which+    describe a portion of work to be performed by a worker.+ -}+module LogicGrowsOnTrees.Workload+    (+    -- * Workload type and simple functions+      Workload(..)+    , entire_workload+    , workloadDepth+    -- * Exploration functions+    -- $exploration+    , exploreTreeWithinWorkload+    , exploreTreeTWithinWorkload+    , exploreTreeUntilFirstWithinWorkload+    , exploreTreeTUntilFirstWithinWorkload+    , exploreTreeUntilFoundWithinWorkload+    , exploreTreeTUntilFoundWithinWorkload+    ) where++import Control.Monad ((>=>))+import Data.Derive.Serialize+import Data.DeriveTH+import Data.Function (on)+import Data.Monoid (Monoid(..))+import qualified Data.Sequence as Seq+import Data.Serialize++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Path++--------------------------------------------------------------------------------+-------------------- Workload type and simple functions ------------------------+--------------------------------------------------------------------------------++{-| A 'Workload' describes a portion of work to be performed by a worker;  it+    consists of a 'Path' to the subtree where the workload is located paired+    with a 'Checkpoint' that indicates which parts of that subtree have already+    been explored.+ -}+data Workload = Workload+    {   workloadPath :: Path+    ,   workloadCheckpoint :: Checkpoint+    } deriving (Eq,Show)+$( derive makeSerialize ''Workload )++{-| Workloads are ordered first by their depth (the length of the 'Path'+    component), second by the value of the 'Path' component itself, and finally+    by the value of the 'Checkpoint' component. This ordering was chosen because+    there are times where it is nice to be able to conveniently order+    'Workload's by depth.+ -}+instance Ord Workload where+    x `compare` y =+        case (compare `on` workloadDepth) x y of+            EQ → case (compare `on` workloadPath) x y of+                EQ → (compare `on` workloadCheckpoint) x y+                c → c+            c → c++{-| A 'Workload' that consists of the entire tree. -}+entire_workload :: Workload+entire_workload = Workload Seq.empty Unexplored++{-| The depth of the workload, equal to the length of the 'Path' component. -}+workloadDepth :: Workload → Int+workloadDepth = Seq.length . workloadPath++--------------------------------------------------------------------------------+----------------------------- Exploration functions --------------------------------+--------------------------------------------------------------------------------++{- $exploration+The functions in this section explore the part of a tree that is given by a+'Workload'.+-}++{-| Explores the nodes in a pure tree given by a 'Workload', and sums+    over all the results in the leaves.+ -}+exploreTreeWithinWorkload ::+    Monoid α ⇒+    Workload →+    Tree α →+    α+exploreTreeWithinWorkload Workload{..} =+    exploreTreeStartingFromCheckpoint workloadCheckpoint+    .+    sendTreeDownPath workloadPath++{-| Same as 'exploreTreeWithinWorkload' but for an impure tree. -}+exploreTreeTWithinWorkload ::+    (Monad m, Monoid α) ⇒+    Workload →+    TreeT m α →+    m α+exploreTreeTWithinWorkload Workload{..} =+    sendTreeTDownPath workloadPath+    >=>+    exploreTreeTStartingFromCheckpoint workloadCheckpoint++{-| Explores the nodes in a pure tree given by a 'Workload' until+    a result (i.e. a leaf) has been found; if a result has been found then it is+    returned wrapped in 'Just', otherwise 'Nothing' is returned.+ -}+   +exploreTreeUntilFirstWithinWorkload ::+    Workload →+    Tree α →+    Maybe α+exploreTreeUntilFirstWithinWorkload Workload{..} =+    exploreTreeUntilFirstStartingFromCheckpoint workloadCheckpoint+    .+    sendTreeDownPath workloadPath++{-| Same as 'exploreTreeUntilFirstWithinWorkload' but for an impure tree. -}+exploreTreeTUntilFirstWithinWorkload ::+    Monad m ⇒+    Workload →+    TreeT m α →+    m (Maybe α)+exploreTreeTUntilFirstWithinWorkload Workload{..} =+    sendTreeTDownPath workloadPath+    >=>+    exploreTreeTUntilFirstStartingFromCheckpoint workloadCheckpoint++{-| Explores the nodes in a pure tree given by a 'Workload', summing+    all results encountered (i.e., in the leaves) until the current partial sum+    satisfies the condition provided by the first parameter.++    See 'LogicGrowsOnTrees.exploreTreeUntilFound' for more details.+ -}+exploreTreeUntilFoundWithinWorkload ::+    Monoid α ⇒+    (α → Bool) →+    Workload →+    Tree α →+    (α,Bool)+exploreTreeUntilFoundWithinWorkload condition Workload{..} =+    exploreTreeUntilFoundStartingFromCheckpoint condition workloadCheckpoint+    .+    sendTreeDownPath workloadPath++{-| Same as 'exploreTreeUntilFoundWithinWorkload' but for an impure tree. -}+exploreTreeTUntilFoundWithinWorkload ::+    (Monoid α, Monad m) ⇒+    (α → Bool) →+    Workload →+    TreeT m α →+    m (α,Bool)+exploreTreeTUntilFoundWithinWorkload condition Workload{..} =+    sendTreeTDownPath workloadPath+    >=>+    exploreTreeTUntilFoundStartingFromCheckpoint condition workloadCheckpoint
+ tests/test-nqueens.hs view
@@ -0,0 +1,972 @@+-- Language extensions {{{+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnicodeSyntax #-}+-- }}}++-- Imports {{{+import Control.Applicative+import Control.Arrow ((***))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict++import Data.Bits+import Data.List+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Word++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit++import Text.Printf++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Examples.Queens+import LogicGrowsOnTrees.Examples.Queens.Advanced+import LogicGrowsOnTrees.Utils.WordSum+-- }}}++-- Functions {{{+checkBlocks :: [(Word,Word)] → Int → Int → Word64 → Word64 → Word64 → Word64 → Assertion -- {{{+checkBlocks+    solution+    window_start+    window_size+    original_occupied_rows+    original_occupied_columns+    original_occupied_negative_diagonals+    original_occupied_positive_diagonals+ = go+   (map (fromIntegral *** fromIntegral) solution)+   (original_occupied_rows .&. rows_and_columns_mask)+   (original_occupied_columns .&. rows_and_columns_mask)+   (original_occupied_negative_diagonals .&. negative_diagonals_mask)+   (original_occupied_positive_diagonals .&. positive_diagonals_mask)+  where+    rows_and_columns_mask = bit window_size - 1+    negative_diagonals_mask = bit (2*window_size-1) - 1+    positive_diagonals_mask = negative_diagonals_mask `rotateR` (window_size-1) +    window_end = window_start+window_size-1+    go :: [(Int,Int)] → Word64 → Word64 → Word64 → Word64 → IO ()+    go [] 0 0 0 0 = return ()+    go []+       occupied_rows+       occupied_columns+       occupied_negative_diagonals+       occupied_positive_diagonals+      = assertFailure (+            printf "non-zero blocks %i %i %i %i (from %i %i %i %i) at row %i for solution: %s"+                occupied_rows+                occupied_columns+                occupied_negative_diagonals+                occupied_positive_diagonals+                original_occupied_rows+                original_occupied_columns+                original_occupied_negative_diagonals+                original_occupied_positive_diagonals+                window_start+                (show solution)+        )+    go ((row,col):rest_solution)+       occupied_rows+       occupied_columns+       occupied_negative_diagonals+       occupied_positive_diagonals+       = do+        let row_bit = if row >= window_start && row <= window_end then bit (row-window_start) else 0+        when (row_bit /= 0) $+            assertBool+                (printf "bit for row %i (%i) in %i was not set for solution %s" row (row-window_start) occupied_rows (show solution))+                (row_bit .&. occupied_rows /= 0)+        let col_bit = if col >= window_start && col <= window_end then bit (col-window_start) else 0+        when (col_bit /= 0) $+            assertBool+                (printf "bit for col %i (%i) in %i was not set for solution %s" col (col-window_start) occupied_columns (show solution))+                (col_bit .&. occupied_columns /= 0)+        let neg_bit = if col+row - 2*window_start >= 0 && col+row - 2*window_start <= 2*(window_size-1) then bit (col+row-2*window_start) else 0+        when (neg_bit /= 0) $+            assertBool+                (printf "bit for negative diagonal %i (%i) in %i was not set for solution %s" (col+row) (col+row-2*window_start) occupied_negative_diagonals (show solution))+                (neg_bit .&. occupied_negative_diagonals /= 0)+        let pos_bit = if col-row >= -(window_size-1) && col-row <= (window_size-1) then 1 `rotate` (col-row) else 0+        when (pos_bit /= 0) $+            assertBool+                (printf "bit for positive diagonal %i (%i) in %i was not set for solution %s" (col-row) (col-row) occupied_positive_diagonals (show solution))+                (pos_bit .&. occupied_positive_diagonals /= 0)+        go rest_solution+           (occupied_rows `xor` row_bit)+           (occupied_columns `xor` col_bit)+           (occupied_negative_diagonals `xor` neg_bit)+           (occupied_positive_diagonals `xor` pos_bit)+-- }}}++checkRightPositiveBlocks :: Int → Word64 → Word64 → Assertion -- {{{+checkRightPositiveBlocks size occupied_positive_diagonals occupied_right_positive_diagonals = go 0 1 1+  where+    go column top_bit right_bit+      | column == size = return ()+      | otherwise = do+         assertEqual+            (printf "for %i, column bit (%s in %i) does not match row bit (%s in %i)"+                 column+                (show top_bit_value)+                 occupied_positive_diagonals+                (show right_bit_value)+                 occupied_right_positive_diagonals+            )+            top_bit_value+            right_bit_value+         go (column+1) (top_bit `rotateR` 1) (right_bit `unsafeShiftL` 1)+      where+         top_bit_value = occupied_positive_diagonals .&. top_bit /= 0+         right_bit_value = occupied_right_positive_diagonals .&. right_bit /= 0+-- }}}++checkSolutionIsValid :: Word → NQueensSolution → Assertion -- {{{+checkSolutionIsValid n solution =+    forM_ (zip [0..] solution) $ \(i,(row1,col1)) → do+        assertBool "row within bounds" $ row1 >= 0 && row1 < n+        assertBool "column within bounds" $ col1 >= 0 && col1 < n+        forM_ (drop (i+1) solution) $ \(row2,col2) → do+            assertBool ("rows conflict in " ++ show solution) $ row1 /= row2+            assertBool ("columns conflict in " ++ show solution) $ col1 /= col2+            assertBool ("negative diagonals conflict in " ++ show solution) $ row1+col1 /= row2+col2+            assertBool ("positive diagonals conflict in " ++ show solution) $ row1-col1 /= row2-col2+-- }}}++checkSolutionsAreValid :: Word → NQueensSolutions → Assertion -- {{{+checkSolutionsAreValid = mapM_ . checkSolutionIsValid+-- }}}++checkSymmetry :: MonadIO m ⇒ Word → NQueensSymmetry → [(Word,Word)] → m () -- {{{+checkSymmetry n correct_symmetry solution =+        liftIO+        .+        assertEqual ("solution has wrong symmetry: " ++ show (reverse solution)) correct_symmetry+        .+        symmetryOf n+        $+        solution+-- }}}++remdups :: (Eq a) => [a] -> [a] -- {{{+remdups []  =  []+remdups (x : []) =  [x]+remdups (x : xx : xs)+ | x == xx   = remdups (x : xs)+ | otherwise = x : remdups (xx : xs)+-- }}}++testSolutionsUsing :: (Word → NQueensSolutions) → (Word → Tree WordSum) → [Test.Framework.Test] -- {{{+testSolutionsUsing nqueensSolutions nqueensCount =+    [testGroup "are valid" $ -- {{{+        map (\n → testCase ("n = " ++ show n) $ checkSolutionsAreValid n (nqueensSolutions n))+            [1..10]+     -- }}}+    ,testGroup "are unique" $ -- {{{+        [ testCase ("n = " ++ show n) $+            let solutions_as_list = nqueensSolutions n+                solutions_as_set = Set.fromList solutions_as_list+            in length solutions_as_list @?= Set.size solutions_as_set+        | n ← [1..10]+        ]+     -- }}}+    ,testGroup "have correct size" -- {{{+        [ testCase ("n = " ++ show n) $+            (correct_count @=?)+            .+            getWordSum+            .+            exploreTree+            .+            nqueensCount+            $+            n+        | n ← [1..14]+        , let correct_count = nqueensCorrectCount n+        ]+     -- }}}+    ,testGroup "match count" -- {{{+        [ testCase ("n = " ++ show n) $+            (nqueensCorrectCount n @=?)+            .+            getWordSum+            .+            exploreTree+            .+            nqueensCount+            $+            n+        | n ← [1..10]+        ]+     -- }}}+    ]+-- }}}+-- }}}++main = defaultMain tests++tests = -- {{{+    [testProperty "reflectBits" $ liftA2 (==) id (reflectBits . reflectBits)+    ,testGroup "reflections and rotations" -- {{{+        [testProperty "reflecting twice = id" $ \n → -- {{{+            liftA2 (==)+                (reflectSolution n . reflectSolution n)+                 id+         -- }}}+        ,testProperty "rotating left twice = rotate 180"$ \n → -- {{{+            liftA2 (==)+                (rotateLeft n . rotateLeft n)+                (rotate180 n)+         -- }}}+        ,testProperty "rotating left four times = id" $ \n → -- {{{+            liftA2 (==)+                (rotateLeft n . rotateLeft n . rotateLeft n . rotateLeft n)+                 id+         -- }}}+        ,testProperty "rotating right twice = rotate 180" $ \n → -- {{{+            liftA2 (==)+                (rotateRight n . rotateRight n)+                (rotate180 n)+         -- }}}+        ,testProperty "rotating right four times = id" $ \n → -- {{{+            liftA2 (==)+                (rotateRight n . rotateRight n . rotateRight n . rotateRight n)+                 id+         -- }}}+        ]+     -- }}}+    ,testGroup "symmetry breaking" -- {{{+        [testGroup "start" $ -- {{{+            let getAllSolutions :: MonadPlus m ⇒ Word → m [(Word,Word)] -- {{{+                getAllSolutions =+                    nqueensStart+                        (++)+                        (const . return)+                        (const . return)+                        (const . const . return)+                        []+            in -- }}}+            [testGroup "correct blocks" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    nqueensStart+                        (++)+                        (\solution NQueensBreak90State{..} → liftIO $+                            checkBlocks+                                solution+                                b90_window_start+                                b90_window_size+                                b90_occupied_rows_and_columns+                                b90_occupied_rows_and_columns+                                b90_occupied_negative_diagonals+                                b90_occupied_positive_diagonals+                        )+                        (\solution NQueensBreak180State{..} → liftIO $ do+                            checkBlocks+                                solution+                                b180_window_start+                                b180_window_size+                                b180_occupied_rows+                                b180_occupied_columns+                                b180_occupied_negative_diagonals+                                b180_occupied_positive_diagonals+                            checkRightPositiveBlocks+                                b180_window_size+                                b180_occupied_positive_diagonals+                                b180_occupied_right_positive_diagonals+                        )+                        (\solution window_size NQueensSearchState{..} → liftIO $ do+                            checkBlocks+                                solution+                                s_row+                                window_size+                                s_occupied_rows+                                s_occupied_columns+                                s_occupied_negative_diagonals+                                s_occupied_positive_diagonals+                        )+                        []+                        n+                | n ← [2..20]+                ]+             -- }}}+            ,testGroup "correct symmetries" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    nqueensStart+                        (++)+                        (const . checkSymmetry n AllRotations)+                        (const . checkSymmetry n Rotate180Only)+                        (const . const . checkSymmetry n NoSymmetries)+                        []+                        n+                | n ← [2..20]+                ]+             -- }}}+            ,testGroup "includes all solution exteriors" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $ do+                    let start_exteriors = Set.fromList . map sort $ getAllSolutions n+                    solution ← nqueensBruteForceSolutions n+                    liftIO+                        .+                        assertBool ("solution " ++ show solution ++ " --> " ++ show (sort . map sort . multiplySolution n NoSymmetries $ extractExteriorFromSolution n 1 solution :: [[(Word,Word)]]) ++ " does not have an exterior in the starting set")+                        .+                        any (+                          flip Set.member start_exteriors+                          .+                          sort+                        )+                        .+                        multiplySolution n NoSymmetries+                        $+                        extractExteriorFromSolution n 1 solution+                | n ← [2..11]+                ]+             -- }}}+            ,testGroup "includes all solutions" -- {{{+                [ testCase ("n = " ++ show n) $+                    let finalizeValueWithMultiplicity m original_solution = do+                            liftIO $ checkSolutionIsValid n (sort original_solution)+                            solutions ← lift get+                            solution ← allFrom . remdups . map sort $ do+                                rotated_solution ← take m . iterate (rotateLeft n) $ original_solution+                                allFrom [rotated_solution,reflectSolution n rotated_solution]+                            liftIO $ assertBool ("solution appears twice: " ++ show solution) (not $ Set.member solution solutions)+                            lift $ modify (Set.insert solution)+                    in+                    (flip execStateT Set.empty+                     .+                     exploreTreeT+                     $+                     nqueensStart+                        (++)+                        (\value NQueensBreak90State{..} →+                            nqueensSearch+                                (++)+                                (finalizeValueWithMultiplicity 1)+                                value+                                b90_window_size+                                $+                                NQueensSearchState+                                    b90_number_of_queens_remaining+                                    b90_window_start+                                    b90_occupied_rows_and_columns+                                    b90_occupied_rows_and_columns+                                    b90_occupied_negative_diagonals+                                    b90_occupied_positive_diagonals+                        )+                        (\value NQueensBreak180State{..} → +                            nqueensSearch+                                (++)+                                (finalizeValueWithMultiplicity 2)+                                value+                                b180_window_size+                                $+                                NQueensSearchState+                                    b180_number_of_queens_remaining+                                    b180_window_start+                                    b180_occupied_rows+                                    b180_occupied_columns+                                    b180_occupied_negative_diagonals+                                    b180_occupied_positive_diagonals+                        )+                        (nqueensSearch (++) (finalizeValueWithMultiplicity 4))+                        []+                        n+                    )+                    >>=+                    (assertEqual "missing solutions" Set.empty+                     .+                     Set.difference (+                         Set.fromList . map sort $ nqueensBruteForceSolutions n+                     )+                    )+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "unique" -- {{{+                [ testCase ("n = " ++ show n) . flip evalStateT Set.empty . exploreTreeT $ do+                    old_solutions ← lift get+                    solution ← sort <$>+                        getAllSolutions n+                        >>=+                        multiplySolution n NoSymmetries+                    if Set.member solution old_solutions+                        then liftIO $ assertFailure ("solution " ++ show solution ++ " occurs twice")+                        else lift $ modify (Set.insert solution)+                | n ← [1..20]+                ]+             -- }}}+            ,testGroup "valid" $ -- {{{+                map (\n → testCase ("n = " ++ show n) . checkSolutionsAreValid n . getAllSolutions $ n)+                    [1..20]+             -- }}}+            ]+         -- }}}+        ,testGroup "break90" $ -- {{{+            let getAllSolutions :: MonadPlus m ⇒ Word → m [(Word,Word)] -- {{{+                getAllSolutions n = break90 [] $ NQueensBreak90State n 0 (fromIntegral n) 0 0 0+                  where+                    break90 =+                        nqueensBreak90+                            (++)+                            return+                            (\value state → return value `mplus` break90 value state)+                            (const . return)+                            (const . const . return)+            in -- }}}+            [testGroup "correct blocks" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let break90 =+                            nqueensBreak90+                                (++)+                                (const $ return ())+                                (\solution state@NQueensBreak90State{..} → do+                                    liftIO $+                                      checkBlocks+                                        solution+                                        b90_window_start+                                        b90_window_size+                                        b90_occupied_rows_and_columns+                                        b90_occupied_rows_and_columns+                                        b90_occupied_negative_diagonals+                                        b90_occupied_positive_diagonals+                                    break90 solution state+                                )+                                (\solution NQueensBreak180State{..} → liftIO $ do+                                    checkBlocks+                                        solution+                                        b180_window_start+                                        b180_window_size+                                        b180_occupied_rows+                                        b180_occupied_columns+                                        b180_occupied_negative_diagonals+                                        b180_occupied_positive_diagonals+                                    checkRightPositiveBlocks+                                        b180_window_size+                                        b180_occupied_positive_diagonals+                                        b180_occupied_right_positive_diagonals+                                )+                                (\solution window_size NQueensSearchState{..} → liftIO $+                                    checkBlocks+                                        solution+                                        s_row+                                        window_size+                                        s_occupied_rows+                                        s_occupied_columns+                                        s_occupied_negative_diagonals+                                        s_occupied_positive_diagonals+                                )+                        in break90 [] $ NQueensBreak90State n 0 (fromIntegral n) 0 0 0+                | n ← [2..20]+                ]+             -- }}}+            ,testGroup "correct symmetries" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let break90 =+                            nqueensBreak90+                                (++)+                                (liftIO . assertEqual "solution has the wrong symmetry" AllRotations . symmetryOf n)+                                (\solution next_state → do+                                    checkSymmetry n AllRotations solution+                                    break90 solution next_state+                                )+                                (const . checkSymmetry n Rotate180Only)+                                (const . const . checkSymmetry n NoSymmetries)+                    in break90 [] $ NQueensBreak90State n 0 (fromIntegral n) 0 0 0+                | n ← [2..20]+                ]+             -- }}}+            ,testGroup "includes all solution exteriors" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $ do+                    let break90_exteriors = Set.fromList . map sort $ getAllSolutions n+                    solution ← nqueensBruteForceSolutions n+                    let maximum_layers = (n+1) `div` 2+                        go layers+                          | layers > maximum_layers = return ()+                          | otherwise =+                                (assertBool ("solution " ++ show solution ++ " --> " ++ show (sort . map sort . allRotationsOf n $ exterior :: [[(Word,Word)]]) ++ " (" ++ show (symmetryOf n exterior) ++ ") does not have a " ++ show layers ++ " exterior in the break90 set")+                                 .+                                 any (+                                   flip Set.member break90_exteriors+                                   .+                                   sort+                                  )+                                  .+                                  allRotationsOf n+                                  $+                                  exterior+                                 ) >> if hasRotate90Symmetry n exterior then go (layers+1) else return ()+                           | otherwise = go (layers+1)+                           where+                             exterior = extractExteriorFromSolution n layers solution+                    liftIO $ go 1+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "includes all solutions" -- {{{+                [ testCase ("n = " ++ show n) $+                    let finalizeValueWithMultiplicity m original_solution = do+                            liftIO $ checkSolutionIsValid n (sort original_solution)+                            solutions ← lift get+                            solution ← allFrom . remdups . map sort . take m . iterate (rotateLeft n) $ original_solution+                            liftIO $ assertBool ("solution appears twice: " ++ show solution) (not $ Set.member solution solutions)+                            lift $ modify (Set.insert solution)+                        break90 =+                            nqueensBreak90+                                (++)+                                (finalizeValueWithMultiplicity 4)+                                 break90+                                (\value NQueensBreak180State{..} →+                                    nqueensSearch (++) (finalizeValueWithMultiplicity 2) value b180_window_size $+                                        NQueensSearchState+                                            b180_number_of_queens_remaining+                                            b180_window_start+                                            b180_occupied_rows+                                            b180_occupied_columns+                                            b180_occupied_negative_diagonals+                                            b180_occupied_positive_diagonals+                                )+                                (nqueensSearch (++) (finalizeValueWithMultiplicity 4))+                    in (flip execStateT Set.empty+                        .+                        exploreTreeT+                        $+                        break90 [] $ NQueensBreak90State n 0 (fromIntegral n) 0 0 0+                        :: IO (Set NQueensSolution)+                       ) >>= assertEqual "missing solutions" Set.empty+                             .+                             Set.difference (+                                Set.fromList . map sort $ nqueensBruteForceSolutions n+                             )+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "unique" -- {{{+                [ testCase ("n = " ++ show n) . flip evalStateT Set.empty . exploreTreeT $ do+                    old_solutions ← lift get+                    solution ← sort <$>+                        getAllSolutions n+                        >>=+                        multiplySolution n NoSymmetries+                    if (Set.member solution old_solutions)+                        then liftIO $ assertFailure ("solution " ++ show solution ++ " occurs twice")+                        else lift $ modify (Set.insert solution)+                | n ← [1..20]+                ]+             -- }}}+            ,testGroup "valid" $ -- {{{+                map (\n → testCase ("n = " ++ show n) . checkSolutionsAreValid n . getAllSolutions $ n)+                    [2..20]+             -- }}}+            ]+         -- }}}+        ,testGroup "break180" $ -- {{{+            let getAllSolutions :: MonadPlus m ⇒ Word → m [(Word,Word)] -- {{{+                getAllSolutions n = break180 [] $ NQueensBreak180State n 0 (fromIntegral n) 0 0 0 0 0+                  where+                    break180 =+                        nqueensBreak180+                            (++)+                             return+                            (\value state → return value `mplus` break180 value state)+                            (const . const . return)+            in -- }}}+            [testGroup "correct blocks" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let break180 =+                            nqueensBreak180+                                (++)+                                (const $ return ())+                                (\solution state@NQueensBreak180State{..} → do+                                    liftIO $ do+                                      checkBlocks+                                        solution+                                        b180_window_start+                                        b180_window_size+                                        b180_occupied_rows+                                        b180_occupied_columns+                                        b180_occupied_negative_diagonals+                                        b180_occupied_positive_diagonals+                                      checkRightPositiveBlocks+                                        b180_window_size+                                        b180_occupied_positive_diagonals+                                        b180_occupied_right_positive_diagonals+                                    break180 solution state+                                )+                                (\solution window_size NQueensSearchState{..} → liftIO $+                                    checkBlocks+                                        solution+                                        s_row+                                        window_size+                                        s_occupied_rows+                                        s_occupied_columns+                                        s_occupied_negative_diagonals+                                        s_occupied_positive_diagonals+                                )+                    in break180 [] $ NQueensBreak180State n 0 (fromIntegral n) 0 0 0 0 0+                | n ← [2..14]+                ]+             -- }}}+            ,testGroup "correct symmetries" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let break180 =+                            nqueensBreak180+                                (++)+                                (liftIO . assertBool "solution does not have 180 symmetry" . hasRotate180Symmetry n)+                                (\solution next_state → do+                                    liftIO $+                                        assertBool+                                            (printf "solution does not have 180 symmetry: %s" (show solution))+                                            (hasRotate180Symmetry n solution)+                                    break180 solution next_state+                                )+                                (const . const . checkSymmetry n NoSymmetries)+                    in break180 [] $ NQueensBreak180State n 0 (fromIntegral n) 0 0 0 0 0+                | n ← [2..14]+                ]+             -- }}}+            ,testGroup "includes all solution exteriors" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $ do+                    let break180_exteriors = Set.fromList . map sort $ getAllSolutions n+                    solution ← nqueensBruteForceSolutions n+                    let maximum_layers = (n+1) `div` 2+                        go layers+                          | layers > maximum_layers = return ()+                          | otherwise =+                                (assertBool ("solution " ++ show solution ++ " --> " ++ show (sort . map sort . allRotationsOf n $ exterior :: [[(Word,Word)]]) ++ " (" ++ show (symmetryOf n exterior) ++ ") does not have a " ++ show layers ++ " exterior in the break90 set")+                                 .+                                 any (+                                   flip Set.member break180_exteriors+                                   .+                                   sort+                                  )+                                  .+                                  allRotationsOf n+                                  $+                                  exterior+                                 ) >> if hasRotate180Symmetry n exterior then go (layers+1) else return ()+                           | otherwise = go (layers+1)+                           where+                             exterior = extractExteriorFromSolution n layers solution+                    liftIO $ go 1+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "includes all solutions" -- {{{+                [ testCase ("n = " ++ show n) $+                    let finalizeValueWithMultiplicity multiply original_solution = do+                            liftIO $ checkSolutionIsValid n (sort original_solution)+                            solutions ← lift get+                            let rotated_solutions = remdups . map sort . multiply $ original_solution+                            solution ← allFrom rotated_solutions+                            liftIO $ assertBool (printf "solution appears twice: %s --> %s" (show solution) (show rotated_solutions)) (not $ Set.member solution solutions)+                            lift $ modify (Set.insert solution)+                        break180 =+                            nqueensBreak180+                                (++)+                                (finalizeValueWithMultiplicity $ \x → [x])+                                 break180+                                (nqueensSearch (++) (finalizeValueWithMultiplicity $ \x → [x,rotate180 n x]))+                    in (flip execStateT Set.empty+                        .+                        exploreTreeT+                        $+                        break180 [] $ NQueensBreak180State n 0 (fromIntegral n) 0 0 0 0 0+                        :: IO (Set NQueensSolution)+                       ) >>= assertEqual "missing solutions" Set.empty+                             .+                             Set.difference (+                                Set.fromList . map sort $ nqueensBruteForceSolutions n+                             )+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "unique" -- {{{+                [ testCase ("n = " ++ show n) . flip evalStateT Set.empty . exploreTreeT $ do+                    old_solutions ← lift get+                    solution ← sort <$>+                        getAllSolutions n+                        >>=+                        multiplySolution n NoSymmetries+                    if (Set.member solution old_solutions)+                        then liftIO $ assertFailure ("solution " ++ show solution ++ " occurs twice")+                        else lift $ modify (Set.insert solution)+                | n ← [1..14]+                ]+             -- }}}+            ,testGroup "valid" $ -- {{{+                map (\n → testCase ("n = " ++ show n) . checkSolutionsAreValid n . getAllSolutions $ n)+                    [2..14]+             -- }}}+            ]+         -- }}}+        ,testGroup "start + break90 + break180" $ -- {{{+            let getAllSolutions :: MonadPlus m ⇒ Word → m [(Word,Word)] -- {{{+                getAllSolutions = nqueensStart (++) callback90 callback180 search []+                  where+                    callback90 value state = return value `mplus` break90 value state+                    callback180 value state = return value `mplus` break180 value state+                    break90 = nqueensBreak90 (++) return callback90 callback180 search+                    break180 = nqueensBreak180 (++) return callback180 search+                    search = const . const . return+            in -- }}}+            [testGroup "correct blocks" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let callback90 solution state@NQueensBreak90State{..} =do+                            liftIO $+                              checkBlocks+                                solution+                                b90_window_start+                                b90_window_size+                                b90_occupied_rows_and_columns+                                b90_occupied_rows_and_columns+                                b90_occupied_negative_diagonals+                                b90_occupied_positive_diagonals+                            break90 solution state+                        callback180 solution state@NQueensBreak180State{..} = do+                            liftIO $ do+                              checkBlocks+                                solution+                                b180_window_start+                                b180_window_size+                                b180_occupied_rows+                                b180_occupied_columns+                                b180_occupied_negative_diagonals+                                b180_occupied_positive_diagonals+                              checkRightPositiveBlocks+                                b180_window_size+                                b180_occupied_positive_diagonals+                                b180_occupied_right_positive_diagonals+                            break180 solution state+                        callbackSearch solution window_size NQueensSearchState{..} = liftIO $+                            checkBlocks+                                solution+                                s_row+                                window_size+                                s_occupied_rows+                                s_occupied_columns+                                s_occupied_negative_diagonals+                                s_occupied_positive_diagonals+                        break90 =+                            nqueensBreak90+                                (++)+                                (const $ return ())+                                callback90+                                callback180+                                callbackSearch+                        break180 =+                            nqueensBreak180+                                (++)+                                (const $ return ())+                                callback180+                                callbackSearch+                    in nqueensStart+                        (++)+                        callback90+                        callback180+                        callbackSearch+                        []+                        n+                | n ← [2..14]+                ]+             -- }}}+            ,testGroup "correct symmetries" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $+                    let callback90 solution state = do+                            checkSymmetry n AllRotations solution+                            break90 solution state+                        callback180 solution next_state = do+                            liftIO $+                                assertBool+                                    (printf "solution does not have 180 symmetry: %s" (show solution))+                                    (hasRotate180Symmetry n solution)+                            break180 solution next_state+                        callbackSearch =+                            const . const . checkSymmetry n NoSymmetries+                        break90 =+                            nqueensBreak90+                                (++)+                                (liftIO . assertEqual "solution has the correct symmetry" AllRotations . symmetryOf n)+                                callback90+                                callback180+                                callbackSearch+                        break180 =+                            nqueensBreak180+                                (++)+                                (liftIO . assertEqual "solution has the correct symmetry" Rotate180Only . symmetryOf n)+                                callback180+                                callbackSearch+                    in nqueensStart+                        (++)+                        callback90+                        callback180+                        callbackSearch+                        []+                        n+                | n ← [2..14]+                ]+             -- }}}+            ,testGroup "includes all solution exteriors" -- {{{+                [ testCase ("n = " ++ show n) . exploreTreeT $ do+                    let all_exteriors = Set.fromList . map sort $ getAllSolutions n+                    solution ← nqueensBruteForceSolutions n+                    let maximum_layers = (n+1) `div` 2+                        go layers+                          | layers > maximum_layers = return ()+                          | otherwise =+                                (assertBool ("solution " ++ show solution ++ " --> " ++ show (sort . map sort . allRotationsAndReflectionsOf n $ exterior :: [[(Word,Word)]]) ++ " (" ++ show (symmetryOf n exterior) ++ ") does not have a " ++ show layers ++ " exterior in the set")+                                 .+                                 any (+                                   flip Set.member all_exteriors+                                   .+                                   sort+                                  )+                                  .+                                  allRotationsAndReflectionsOf n+                                  $+                                  exterior+                                 ) >> if symmetryOf n exterior > NoSymmetries then go (layers+1) else return ()+                           | otherwise = go (layers+1)+                           where+                             exterior = extractExteriorFromSolution n layers solution+                    liftIO $ go 1+                | n ← [2..12]+                ]+             -- }}}+            ,testGroup "includes all solutions" -- {{{+                [ testCase ("n = " ++ show n) $+                    let finalizeValueWithSymmetry symmetry original_solution = do+                            liftIO $ checkSolutionIsValid n (sort original_solution)+                            liftIO $ checkSymmetry n symmetry (sort original_solution)+                            solutions ← lift get+                            let multiplied_solutions = map sort . multiplySolution n symmetry $ original_solution+                            solution ← allFrom multiplied_solutions+                            liftIO $ assertBool (printf "solution appears twice: %s --> %s" (show solution) (show multiplied_solutions)) (not $ Set.member solution solutions)+                            lift $ modify (Set.insert solution)+                        break90 =+                            nqueensBreak90+                                (++)+                                (finalizeValueWithSymmetry AllRotations)+                                 break90+                                 break180+                                 search+                        break180 =+                            nqueensBreak180+                                (++)+                                (finalizeValueWithSymmetry Rotate180Only)+                                 break180+                                 search+                        search =+                            nqueensSearch+                                (++)+                                (finalizeValueWithSymmetry NoSymmetries)+                    in (flip execStateT Set.empty+                        .+                        exploreTreeT+                        $+                        nqueensStart+                            (++)+                             break90+                             break180+                             search+                             []+                             n+                        :: IO (Set NQueensSolution)+                       ) >>= assertEqual "missing solutions" Set.empty+                             .+                             Set.difference (+                                Set.fromList . map sort $ nqueensBruteForceSolutions n+                             )+                | n ← [4..12]+                ]+             -- }}}+            ,testGroup "unique" -- {{{+                [ testCase ("n = " ++ show n) . flip evalStateT Set.empty . exploreTreeT $ do+                    old_solutions ← lift get+                    solution ← sort <$>+                        getAllSolutions n+                        >>=+                        multiplySolution n NoSymmetries+                    if (Set.member solution old_solutions)+                        then liftIO $ assertFailure ("solution " ++ show solution ++ " occurs twice")+                        else lift $ modify (Set.insert solution)+                | n ← [1..14]+                ]+             -- }}}+            ,testGroup "valid" $ -- {{{+                map (\n → testCase ("n = " ++ show n) . checkSolutionsAreValid n . getAllSolutions $ n)+                    [2..14]+             -- }}}+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "brute force solutions" -- {{{+        [testGroup "are valid" $ -- {{{+            map (\n → testCase ("n = " ++ show n) $ checkSolutionsAreValid n (nqueensBruteForceSolutions n))+                [1..10]+         -- }}}+        ,testGroup "are unique" $ -- {{{+            [ testCase ("n = " ++ show n) $+                let solutions_as_list = nqueensBruteForceSolutions n+                    solutions_as_set = Set.fromList solutions_as_list+                in length solutions_as_list @?= Set.size solutions_as_set+            | n ← [1..10]+            ]+         -- }}}+        ,testGroup "match count" -- {{{+            [ testCase ("n = " ++ show n) $+                (correct_count @=?)+                .+                getWordSum+                .+                exploreTree+                .+                nqueensBruteForceCount+                $+                n+            | n ← [1..10]+            , let correct_count = nqueensCorrectCount n+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "C solutions" -- {{{+        [testGroup "are valid" $ -- {{{+            map (\n → testCase ("n = " ++ show n) $ checkSolutionsAreValid n (nqueensCSolutions n))+                [1..10]+         -- }}}+        ,testGroup "are unique" $ -- {{{+            [ testCase ("n = " ++ show n) $+                let solutions_as_list = nqueensCSolutions n+                    solutions_as_set = Set.fromList solutions_as_list+                in length solutions_as_list @?= Set.size solutions_as_set+            | n ← [1..10]+            ]+         -- }}}+        ,testGroup "match count" -- {{{+            [ testCase ("n = " ++ show n) $+                (correct_count @=?)+                .+                getWordSum+                .+                exploreTree+                .+                nqueensCCount+                $+                n+            | n ← [1..10]+            , let correct_count = nqueensCorrectCount n+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "solutions" $ testSolutionsUsing nqueensSolutions nqueensCount+    ,testGroup "solutions using sets" $ testSolutionsUsing nqueensUsingSetsSolutions nqueensUsingSetsCount+    ,testGroup "solutions using bits" $ testSolutionsUsing nqueensUsingBitsSolutions nqueensUsingBitsCount+    ]+-- }}}
+ tests/tests.hs view
@@ -0,0 +1,1858 @@+-- Language extensions {{{+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoRec #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}+-- }}}++-- Imports {{{+import Prelude hiding (catch)+import Control.Applicative+import Control.Arrow ((&&&),second)+import Control.Concurrent+import Control.Exception+import Control.Lens (_1,_2,(%=),(<+=),use)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Operational (ProgramViewT(..),view)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.State (StateT,evalStateT)+import Control.Monad.Trans.Writer++import Data.Bits+import Data.Composition ((.*))+import Data.Function+import Data.Functor.Identity+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)+import Data.IORef+import qualified Data.IVar as IVar+import Data.List (sort)+import Data.Maybe+import qualified Data.Map as Map+import Data.Monoid+import Data.Sequence ((<|),(|>))+import qualified Data.Sequence as Seq+import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize(),encode)+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Typeable+import qualified Data.UUID as UUID+import Data.UUID (UUID)+import Data.Void (absurd)+import Data.Word++import Debug.Trace (trace)++import Text.Printf++import System.Directory (getTemporaryDirectory,removeFile)+import System.IO+import System.IO.Unsafe+import System.Log.Logger (Priority(..),updateGlobalLogger,rootLoggerName,setLevel)+import System.Random++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Test.Framework.Providers.SmallCheck as Small+import Test.HUnit hiding (Test,Path)+import Test.QuickCheck.Arbitrary hiding ((><))+import Test.QuickCheck.Gen+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Modifiers+import Test.QuickCheck.Monadic+import Test.QuickCheck.Property hiding ((.&.),(==>))+import Test.SmallCheck ((==>))+import Test.SmallCheck.Series (Serial(..))+import Test.SmallCheck.Drivers as Small (test)++import LogicGrowsOnTrees+import LogicGrowsOnTrees.Checkpoint+import LogicGrowsOnTrees.Examples.MapColoring+import LogicGrowsOnTrees.Location+import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads+import qualified LogicGrowsOnTrees.Parallel.Common.Workgroup as Workgroup+import LogicGrowsOnTrees.Parallel.ExplorationMode+import LogicGrowsOnTrees.Parallel.Main (RunOutcome(..),TerminationReason(..))+import LogicGrowsOnTrees.Parallel.Purity+import LogicGrowsOnTrees.Path+import LogicGrowsOnTrees.Parallel.Common.RequestQueue hiding (setWorkloadBufferSize)+import LogicGrowsOnTrees.Parallel.Common.Supervisor+import LogicGrowsOnTrees.Utils.Handle (send,receive)+import LogicGrowsOnTrees.Utils.PerfectTree+import LogicGrowsOnTrees.Utils.WordSum+import LogicGrowsOnTrees.Workload+import LogicGrowsOnTrees.Parallel.Common.Worker+-- }}}++-- Helpers {{{++-- Instances {{{+-- Newtypes {{{+newtype UniqueTreeT m = UniqueTree { unwrapUniqueTree :: TreeT m IntSet }+newtype NullTreeT m = NullTree { unwrapNullTree :: TreeT m IntSet }+-- }}}++-- Arbitrary {{{+instance Arbitrary BranchChoice where arbitrary = elements [LeftBranch,RightBranch]++instance Arbitrary UUID where -- {{{+    arbitrary = MkGen (\r _ -> fst (random r))+-- }}}++instance (Arbitrary α, Monoid α, Serialize α, Functor m, Monad m) ⇒ Arbitrary (TreeT m α) where -- {{{+    arbitrary = fmap ($ mempty) (sized arb)+      where+        arb :: Monoid α ⇒ Int → Gen (α → TreeT m α)+        arb 0 = null+        arb 1 = frequency+            [(1,null)+            ,(1,processPlus)+            ,(2,resultPlus)+            ,(2,cachedPlus)+            ]+        arb n = frequency+            [(1,liftM2 (>=>) processPlus (arb n))+            ,(2,liftM2 (>=>) resultPlus (arb n))+            ,(2,liftM2 (>=>) cachedPlus (arb n))+            ,(4, do left_size ← choose (0,n)+                    let right_size = n-left_size+                    liftM2 (liftA2 mplus)+                        (arb left_size)+                        (arb right_size)+             )+            ]++        null :: Gen (α → TreeT m α)+        null = return (const mzero)++        result, cached :: Gen (TreeT m α)+        result = fmap return arbitrary+        cached = fmap cache arbitrary++        resultPlus, cachedPlus :: Monoid α ⇒ Gen (α → TreeT m α)+        resultPlus = (\x → flip fmap x . mappend) <$> result+        cachedPlus = (\x → flip fmap x . mappend) <$> cached++        processPlus :: Gen (α → TreeT m α)+        processPlus = return processPendingRequestsAndReturn+-- }}}++instance Monad m ⇒ Arbitrary (NullTreeT m) where -- {{{+    arbitrary = (NullTree . ($ (const $ return ()))) <$> randomNullTreeWithHooks+-- }}}++instance Monad m ⇒ Arbitrary (UniqueTreeT m) where -- {{{+    arbitrary = (UniqueTree . ($ (const $ return ()))) <$> randomUniqueTreeWithHooks+-- }}}++instance Arbitrary Checkpoint where -- {{{+    arbitrary = sized arb+      where+        arb 0 = elements [Explored,Unexplored]+        arb n = frequency+                    [(1,return Explored)+                    ,(1,return Unexplored)+                    ,(1,liftM2 CachePoint (fmap encode (arbitrary :: Gen Int)) (arb (n-1)))+                    ,(2,liftM2 ChoicePoint (arb (n `div` 2)) (arb (n `div` 2)))+                    ]+-- }}}++instance Arbitrary Location where arbitrary = fmap labelFromBranching (arbitrary :: Gen [BranchChoice])++instance Arbitrary Step where -- {{{+    arbitrary = oneof+        [CacheStep <$> arbitrary+        ,ChoiceStep <$> arbitrary+        ]+-- }}}++instance Arbitrary α ⇒ Arbitrary (Solution α) where -- {{{+    arbitrary = Solution <$> arbitrary <*> arbitrary+-- }}}++instance Arbitrary α ⇒ Arbitrary (Progress α) where -- {{{+    arbitrary = Progress <$> arbitrary <*> arbitrary+-- }}}++instance Arbitrary α ⇒ Arbitrary (ProgressUpdate α) where -- {{{+    arbitrary = ProgressUpdate <$> arbitrary <*> arbitrary+-- }}}++instance Arbitrary α ⇒ Arbitrary (StolenWorkload α) where -- {{{+    arbitrary = StolenWorkload <$> arbitrary <*> arbitrary+-- }}}++instance Arbitrary Workload where -- {{{+    arbitrary = Workload <$> arbitrary <*> arbitrary+-- }}}+-- }}}++-- Serial {{{+instance Serial IO All where series = All <$> series+instance Serial IO Any where series = Any <$> series+instance Serial IO Word where series = (fromIntegral :: Int → Word) . abs <$> series+instance Serial IO (Sum Int) where series = Sum <$> series+instance Serial IO (Set String) where series = Set.fromList <$> series+-- }}}++-- Serialize {{{+instance Serialize UUID where -- {{{+    put = Serialize.putLazyByteString . UUID.toByteString+    get = fromJust . UUID.fromByteString <$> Serialize.getLazyByteString 16+-- }}}++instance Serialize (Sum Int) where -- {{{+    put = Serialize.put . getSum+    get = fmap Sum Serialize.get+-- }}}+-- }}} Serialize++-- Show {{{+instance Show UniqueTree where show = show . unwrapUniqueTree+-- }}}+-- }}}++-- Exceptions {{{+-- TestException {{{+data TestException = TestException Int deriving (Eq,Show,Typeable)+instance Exception TestException+-- }}}+-- }}}++-- Type alises {{{+type UniqueTree = UniqueTreeT Identity+type NullTree = NullTreeT Identity+-- }}}++-- Functions {{{+addAcceptOneWorkloadAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef (Maybe (worker_id,Workload)),SupervisorCallbacks exploration_mode worker_id IO)+addAcceptOneWorkloadAction actions = do+    maybe_worker_and_workload_ref ← newIORef (Nothing :: Maybe (worker_id,Workload))+    return (maybe_worker_and_workload_ref, actions {+        sendWorkloadToWorker = \workload worker_id → do+            maybe_old_workload ← readIORef maybe_worker_and_workload_ref+            case maybe_old_workload of+                Nothing → return ()+                Just _ → error "workload has been submitted already!"+            writeIORef maybe_worker_and_workload_ref $ Just (worker_id,workload)+    })+-- }}}++addAcceptMultipleWorkloadsAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef [(worker_id,Workload)],SupervisorCallbacks exploration_mode worker_id IO)+addAcceptMultipleWorkloadsAction actions = do+    workers_and_workloads_ref ← newIORef []+    return (workers_and_workloads_ref, actions {+        sendWorkloadToWorker = \workload worker_id →+            readIORef workers_and_workloads_ref+            >>=+            writeIORef workers_and_workloads_ref . (++ [(worker_id,workload)])+    })+-- }}}++addAppendWorkloadStealBroadcastIdsAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef [[worker_id]],SupervisorCallbacks exploration_mode worker_id IO)+addAppendWorkloadStealBroadcastIdsAction actions = do+    broadcasts_ref ← newIORef ([] :: [[worker_id]])+    return (broadcasts_ref, actions {+        broadcastWorkloadStealToWorkers = \worker_ids →+            modifyIORef broadcasts_ref (++ [worker_ids])+    })+-- }}}++addAppendProgressBroadcastIdsAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef [[worker_id]],SupervisorCallbacks exploration_mode worker_id IO)+addAppendProgressBroadcastIdsAction actions = do+    broadcasts_ref ← newIORef ([] :: [[worker_id]])+    return (broadcasts_ref, actions {+        broadcastProgressUpdateToWorkers = \worker_ids →+            modifyIORef broadcasts_ref (++ [worker_ids])+    })+-- }}}++addReceiveCurrentProgressAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef (Maybe (ProgressFor exploration_mode)),SupervisorCallbacks exploration_mode worker_id IO)+addReceiveCurrentProgressAction actions = do+    maybe_progress_ref ← newIORef (Nothing :: Maybe ip)+    return (maybe_progress_ref, actions {+        receiveCurrentProgress = \progress → do+            maybe_old_progress ← readIORef maybe_progress_ref+            case maybe_old_progress of+                Nothing → return ()+                Just _ → error "progress update has been received already!"+            writeIORef maybe_progress_ref $ Just progress+    })+-- }}}++addSetWorkloadStealBroadcastIdsAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    IO (IORef [worker_id],SupervisorCallbacks exploration_mode worker_id IO)+addSetWorkloadStealBroadcastIdsAction actions = do+    broadcasts_ref ← newIORef ([] :: [worker_id])+    return (broadcasts_ref, actions {+        broadcastWorkloadStealToWorkers = writeIORef broadcasts_ref+    })+-- }}}++checkFoundAgainstThreshold :: Int → IntSet → (IntSet,Bool) → IO Bool -- {{{+checkFoundAgainstThreshold threshold solutions (result,found)+  | found = do+        assertBool "check that the result set is big enough" $ IntSet.size result >= threshold+        assertBool "check that the results are all in the full set of solutions" $ result `IntSet.isSubsetOf` solutions+        return True+  | otherwise = do+        assertBool (printf "check that the unsuccessful result is small enough (%i < %i)" (IntSet.size result) threshold) $ IntSet.size result < threshold+        assertEqual "check that the result equals the solutions" solutions result+        return True+-- }}}++echo :: Show α ⇒ α → α -- {{{+echo x = trace (show x) x+-- }}}++echoWithLocation :: Show α ⇒ String → α → α -- {{{+echoWithLocation label x = trace (label ++ " " ++ show x) x+-- }}}++ignoreAcceptWorkloadAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    SupervisorCallbacks exploration_mode worker_id IO+ignoreAcceptWorkloadAction actions = actions { sendWorkloadToWorker = \_ _ → return () }+-- }}}++ignoreWorkloadStealAction :: -- {{{+    SupervisorCallbacks exploration_mode worker_id IO →+    SupervisorCallbacks exploration_mode worker_id IO+ignoreWorkloadStealAction actions = actions { broadcastWorkloadStealToWorkers = \_ → return () }+-- }}}++frequencyT :: (MonadTrans t, Monad (t Gen)) ⇒ [(Int, t Gen a)] → t Gen a -- {{{+frequencyT [] = error "frequencyT used with empty list"+frequencyT xs0 = lift (choose (1, tot)) >>= pick xs0+ where+  tot = sum (map fst xs0)++  pick ((k,x):xs) n+    | n <= k    = x+    | otherwise = pick xs (n-k)+  pick _ _  = error "frequencyT.pick used with empty list"+-- }}}++shuffle :: [α] → Gen [α] -- {{{+shuffle [] = return []+shuffle items = do+    index ← choose (0,length items-1)+    let hd = items !! index+        rest = take index items ++ drop (index+1) items+    tl ← shuffle rest+    return (hd:tl)+-- }}}++processPendingRequestsAndReturn :: Monad m ⇒ α → TreeT m α -- {{{+processPendingRequestsAndReturn x = processPendingRequests >> return x+-- }}}++randomCheckpointForTree :: Monoid α ⇒ Tree α → Gen (α,Checkpoint) -- {{{+randomCheckpointForTree (TreeT tree) = go1 tree+  where+    go1 tree = frequency+        [(1,return (exploreTree (TreeT tree),Explored))+        ,(1,return (mempty,Unexplored))+        ,(3,go2 tree)+        ]+    go2 (view → Cache (Identity (Just x)) :>>= k) =+        fmap (second $ CachePoint (encode x)) (go1 (k x))+    go2 (view → Choice (TreeT x) (TreeT y) :>>= k) =+        liftM2 (\(left_result,left) (right_result,right) →+            (left_result `mappend` right_result, ChoicePoint left right)+        ) (go1 (x >>= k)) (go1 (y >>= k))+    go2 (view → ProcessPendingRequests :>>= k) = go2 (k ())+    go2 tree = elements [(exploreTree (TreeT tree),Explored),(mempty,Unexplored)]+-- }}}++randomNullTreeWithHooks :: ∀ m. Monad m ⇒ Gen ((Int → m ()) → TreeT m IntSet) -- {{{+randomNullTreeWithHooks = fmap (($ 0) . curry) . sized $ \n → evalStateT (arb1 n 0) (-1,IntSet.empty)+  where+    arb1, arb2 :: Int → Int → StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)++    arb1 n intermediate = do+        id ← _1 <+= 1+        tree ← arb2 n intermediate+        return $ \args@(_,runHook) → lift (runHook id) >> tree args++    arb2 0 _ = return (const mzero)+    arb2 1 _ = return (const mzero)+    arb2 n intermediate = frequencyT+        [(1,generateForNext processPendingRequestsAndReturn intermediate (arb1 n))+        ,(2,generateForNext return intermediate (arb1 n))+        ,(2,generateForNext cache intermediate (arb1 n))+        ,(4, do left_size ← lift $ choose (0,n)+                let right_size = n-left_size+                liftM2 (liftA2 mplus)+                    (arb1 left_size intermediate)+                    (arb1 right_size intermediate)+         )+        ]++    generateForNext :: -- {{{+        Monad m ⇒+        (Int → TreeT m Int) →+        Int →+        (Int → StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)) →+        StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)+    generateForNext construct intermediate next = do+        x ← lift arbitrary+        let new_intermediate = x `xor` intermediate+        tree ← next new_intermediate+        return $ \(value,runHook) → do+            new_value ← construct . xor x $ value+            tree (new_value,runHook)+    -- }}}+-- }}}++randomPathForTree :: Tree α → Gen Path -- {{{+randomPathForTree (TreeT tree) = go tree+  where+    go (view → Cache (Identity (Just x)) :>>= k) = oneof+        [return Seq.empty+        ,fmap (CacheStep (encode x) <|) (go (k x))+        ]+    go (view → Choice (TreeT x) (TreeT y) :>>= k) = oneof+        [return Seq.empty+        ,fmap (ChoiceStep LeftBranch <|) (go (x >>= k))+        ,fmap (ChoiceStep RightBranch <|) (go (y >>= k))+        ]+    go (view → ProcessPendingRequests :>>= k) = go (k ())+    go _ = return Seq.empty+-- }}}++randomUniqueTreeWithHooks :: ∀ m. Monad m ⇒ Gen ((Int → m ()) → TreeT m IntSet) -- {{{+randomUniqueTreeWithHooks = fmap (($ 0) . curry) . sized $ \n → evalStateT (arb1 n 0) (-1,IntSet.empty)+  where+    arb1, arb2 :: Int → Int → StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)++    arb1 n intermediate = do+        id ← _1 <+= 1+        tree ← arb2 n intermediate+        return $ \args@(_,runHook) → lift (runHook id) >> tree args++    arb2 0 _ = return (const mzero)+    arb2 1 intermediate = frequencyT+        [(1,return (const mzero))+        ,(1,generateUnique processPendingRequestsAndReturn intermediate)+        ,(3,generateUnique return intermediate)+        ,(2,generateUnique cache intermediate)+        ]+    arb2 n intermediate = frequencyT+        [(1,generateForNext processPendingRequestsAndReturn intermediate (arb1 n))+        ,(2,generateForNext return intermediate (arb1 n))+        ,(2,generateForNext cache intermediate (arb1 n))+        ,(4, do left_size ← lift $ choose (0,n)+                let right_size = n-left_size+                liftM2 (liftA2 mplus)+                    (arb1 left_size intermediate)+                    (arb1 right_size intermediate)+         )+        ]++    generateUnique :: -- {{{+        Monad m ⇒+        (IntSet → TreeT m IntSet) →+        Int →+        StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)+    generateUnique construct intermediate = do+        observed ← use _2+        x ← lift (arbitrary `suchThat` (flip IntSet.notMember observed . (xor intermediate)))+        let final_value = x `xor` intermediate+        _2 %= IntSet.insert final_value+        return $ construct . IntSet.singleton . xor x . fst+    -- }}}++    generateForNext :: -- {{{+        Monad m ⇒+        (Int → TreeT m Int) →+        Int →+        (Int → StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)) →+        StateT (Int,IntSet) Gen ((Int,Int → m ()) → TreeT m IntSet)+    generateForNext construct intermediate next = do+        x ← lift arbitrary+        let new_intermediate = x `xor` intermediate+        tree ← next new_intermediate+        return $ \(value,runHook) → do+            new_value ← construct . xor x $ value+            tree (new_value,runHook)+    -- }}}+-- }}}++randomTreeWithoutCache :: Arbitrary α ⇒ Gen (Tree α) -- {{{+randomTreeWithoutCache = sized arb+  where+    arb 0 = frequency+                [(2,result)+                ,(1,null)+                ]+    arb n = frequency+                [(2,result)+                ,(1,bindToArbitrary n result)+                ,(1,bindToArbitrary n null)+                ,(1,bindToArbitrary n process)+                ,(3,liftM2 mplus (arb (n `div` 2)) (arb (n `div` 2)))+                ]+    null = return mzero+    result = fmap return arbitrary+    process = fmap processPendingRequestsAndReturn arbitrary++    bindToArbitrary n = flip (liftM2 (>>)) (arb (n-1))+-- }}}++remdups :: (Eq a) => [a] -> [a] -- {{{+remdups []  =  []+remdups (x : []) =  [x]+remdups (x : xx : xs)+ | x == xx   = remdups (x : xs)+ | otherwise = x : remdups (xx : xs)+-- }}}+-- }}}++-- Values {{{+bad_test_supervisor_actions :: SupervisorCallbacks exploration_mode worker_id m -- {{{+bad_test_supervisor_actions =+    SupervisorCallbacks+    {   broadcastProgressUpdateToWorkers =+            error "broadcastProgressUpdateToWorkers called! :-/"+    ,   broadcastWorkloadStealToWorkers =+            error "broadcastWorkloadStealToWorkers called! :-/"+    ,   receiveCurrentProgress =+            error "receiveCurrentProgress called! :-/"+    ,   sendWorkloadToWorker =+            error "sendWorkloadToWorker called! :-/"+    }+-- }}}+ignore_supervisor_actions :: Monad m ⇒ SupervisorCallbacks exploration_mode worker_id m -- {{{+ignore_supervisor_actions =+    SupervisorCallbacks+    {   broadcastProgressUpdateToWorkers = const $ return ()+    ,   broadcastWorkloadStealToWorkers = const $ return ()+    ,   receiveCurrentProgress = const $ return ()+    ,   sendWorkloadToWorker = const . const $ return ()+    }+-- }}}+endless_tree = endless_tree `mplus` endless_tree+-- }}}++-- }}}++main = do+    -- updateGlobalLogger rootLoggerName (setLevel DEBUG)+    defaultMain tests++tests = -- {{{+    [testGroup "test helpers" $ -- {{{+        [testProperty "UniqueTree has unique results" $ \(UniqueTree tree) → -- {{{+            let results = exploreTree (fmap (:[]) tree )+            in length results == IntSet.size (mconcat results)+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees" -- {{{+        [testGroup "Eq instance" -- {{{+            [testProperty "self" $ \(v :: Tree [()]) → v == v+            ]+         -- }}}+        ,testProperty "allFrom" $ \(x :: [Int]) → x == allFrom x+        ,testProperty "between" $ do -- {{{+            x ← choose ( 0,100) :: Gen Int+            y ← choose (50,100)+            return $ between x y == [x..y]+         -- }}}+        ,testGroup "exploreTree" -- {{{+            [testCase "return" $ exploreTree (return [()]) @?= [()]+            ,testCase "mzero" $ exploreTree (mzero :: Tree [()]) @?= []+            ,testCase "mplus" $ exploreTree (return [1::Int] `mplus` return [2]) @?= [1,2]+            ,testCase "cache" $ exploreTree (cache [42]) @?= [42::Int]+            ,testGroup "cacheMaybe" -- {{{+                [testCase "Nothing" $ exploreTree (cacheMaybe (Nothing :: Maybe [()])) @?= []+                ,testCase "Just" $ exploreTree (cacheMaybe (Just [42])) @?= [42::Int]+                ]+             -- }}}+            ,testGroup "cacheGuard" -- {{{+                [testCase "True" $ exploreTree (cacheGuard False >> return [()]) @?= []+                ,testCase "False" $ exploreTree (cacheGuard True >> return [()]) @?= [()]+                ]+             -- }}}+            ]+         -- }}}+        ,testGroup "exploreTreeT" -- {{{+            [testCase "Writer" $ -- {{{+                (runWriter . exploreTreeT $ do+                    cache [1 :: Int] >>= lift . tell+                    (lift (tell [2]) `mplus` lift (tell [3]))+                    return [42::Int]+                ) @?= ([42,42],[1,2,3])+             -- }}}+            ]+         -- }}}+        ,testGroup "exploreTreeTAndIgnoreResults" -- {{{+            [testCase "Writer" $ -- {{{+                (runWriter . exploreTreeTAndIgnoreResults $ do+                    cache [1 :: Int] >>= lift . tell+                    (lift (tell [2]) `mplus` lift (tell [3]))+                    return [42::Int]+                ) @?= ((),[1,2,3])+             -- }}}+            ]+         -- }}}+        ,testGroup "exploreTreeUntilFirst" -- {{{+            [testCase "return" $ exploreTreeUntilFirst (return 42) @=? (Just 42 :: Maybe Int)+            ,testCase "null" $ exploreTreeUntilFirst mzero @=? (Nothing :: Maybe Int)+            ,testProperty "compared to exploreTree" $ \(tree :: Tree String) →+                exploreTreeUntilFirst tree+                ==+                case exploreTree (fmap (:[]) tree) of+                    [] → Nothing+                    (x:_) → Just x+            ]+         -- }}}+        ,testGroup "exploreTreeTUntilFirst" -- {{{+            [testCase "return" $ runIdentity (exploreTreeTUntilFirst (return 42)) @=? (Just 42 :: Maybe Int)+            ,testCase "null" $ runIdentity(exploreTreeTUntilFirst mzero) @=? (Nothing :: Maybe Int)+            ,testProperty "compared to exploreTreeT" $ \(tree :: TreeT Identity String) →+                runIdentity (exploreTreeTUntilFirst tree)+                ==+                case runIdentity (exploreTreeT (fmap (:[]) tree)) of+                    [] → Nothing+                    (x:_) → Just x+            ]+         -- }}}+        ,testGroup "exploreTreeUntilFound" -- {{{+            [testProperty "compared to exploreTree" $ do+                UniqueTree tree ← arbitrary+                let solutions = exploreTree tree+                threshold ← (+1) <$> choose (0,2*IntSet.size solutions)+                return . unsafePerformIO . checkFoundAgainstThreshold threshold solutions $+                    exploreTreeUntilFound ((>= threshold) . IntSet.size) tree+            ]+         -- }}}+        ,testGroup "exploreTreeTUntilFound" -- {{{+            [testProperty "compared to exploreTreeT" $ do+                UniqueTree tree ← arbitrary+                let solutions = runIdentity (exploreTreeT tree)+                threshold ← (+1) <$> choose (0,2*IntSet.size solutions)+                return . unsafePerformIO . checkFoundAgainstThreshold threshold solutions . runIdentity $+                    exploreTreeTUntilFound ((>= threshold) . IntSet.size) tree+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Checkpoint" -- {{{+        [testGroup "contextFromCheckpoint" -- {{{+            [testProperty "cache" $ \(checkpoint :: Checkpoint) (i :: Int) → -- {{{+                checkpointFromContext (Seq.singleton (CacheContextStep (encode i))) checkpoint+                ==+                (simplifyCheckpointRoot $ CachePoint (encode i) checkpoint)+             -- }}}+            ,testProperty "left branch" $ \(inner_checkpoint :: Checkpoint) (other_tree :: Tree [()]) (other_checkpoint :: Checkpoint) → -- {{{+                (checkpointFromContext (Seq.singleton (LeftBranchContextStep other_checkpoint other_tree)) inner_checkpoint)+                ==+                (simplifyCheckpointRoot $ ChoicePoint inner_checkpoint other_checkpoint)+             -- }}}+            ,testProperty "right branch" $ \(checkpoint :: Checkpoint) → -- {{{+                checkpointFromContext (Seq.singleton RightBranchContextStep) checkpoint+                ==+                (simplifyCheckpointRoot $ ChoicePoint Explored checkpoint)+             -- }}}+            ,testProperty "empty" $ \(checkpoint :: Checkpoint) → -- {{{+                checkpointFromContext Seq.empty checkpoint == checkpoint+             -- }}}+            ]+         -- }}}+        ,testProperty "invertCheckpoint" $ \(tree :: Tree (Set UUID)) → -- {{{+            randomCheckpointForTree tree >>= \(partial_result,checkpoint) → return $+                partial_result == exploreTreeStartingFromCheckpoint (invertCheckpoint checkpoint) tree+         -- }}}+        ,testGroup "Monoid instance" -- {{{+            [testProperty "product results in intersection of solutions" $ \(UniqueTree tree) → do -- {{{+                (_,checkpoint1) ← randomCheckpointForTree tree+                (_,checkpoint2) ← randomCheckpointForTree tree+                let checkpoint3 = checkpoint1 `mappend` checkpoint2+                    solutions1 = exploreTreeStartingFromCheckpoint checkpoint1 tree+                    solutions2 = exploreTreeStartingFromCheckpoint checkpoint2 tree+                    solutions3 = exploreTreeStartingFromCheckpoint checkpoint3 tree+                return $ solutions3 == solutions1 `IntSet.intersection` solutions2+             -- }}}+            ,testCase "throws the correct exceptions" $ -- {{{+                mapM_ (\(x,y) →+                    try (+                        evaluate (x `mappend` y)+                        >>+                        assertFailure (show x ++ " and " ++ show y ++ " were not recognized as being inconsistent")+                    )+                    >>=+                    assertEqual "the thrown exception was incorrect" (Left $ InconsistentCheckpoints x y)+                )+                [((CachePoint (encode (42 :: Int)) Unexplored),(CachePoint (encode (42 :: Integer)) Unexplored))+                ,((ChoicePoint Unexplored Unexplored),CachePoint (encode (42 :: Int)) Unexplored)+                ]+             -- }}}+            ,testProperty "unit element laws" $ \(checkpoint :: Checkpoint) → -- {{{+                (mempty `mappend` checkpoint == checkpoint) && (checkpoint `mappend` mempty == checkpoint)+             -- }}}+            ]+         -- }}}+        ,testProperty "stepThroughTreeStartingFromCheckpoint" $ do -- {{{+            UniqueTree tree ← arbitrary+            (partial_result,checkpoint) ← randomCheckpointForTree tree+            let go state@ExplorationTState{..} current_result =+                    exploreTreeStartingFromCheckpoint+                        (invertCheckpoint (checkpointFromExplorationState state))+                        tree+                    ==+                    current_result+                    &&+                    case stepThroughTreeStartingFromCheckpoint state of+                        (Just result,Nothing) → exploreTree tree == current_result <> result+                        (Nothing,Nothing) → exploreTree tree == current_result+                        (Just result,Just new_state) → go new_state (current_result <> result)+                        (Nothing,Just new_state) → go new_state current_result+            return $ go (initialExplorationState checkpoint tree) partial_result+         -- }}}+        ,testProperty "exploreTreeStartingFromCheckpoint" $ \(UniqueTree tree) → -- {{{+            randomCheckpointForTree tree >>= \(partial_result,checkpoint) → return $+                exploreTree tree ==+                    mappend partial_result (exploreTreeStartingFromCheckpoint checkpoint tree)+         -- }}}+        ,testProperty "exploreTreeUntilFirstStartingFromCheckpoint" $ \(UniqueTree tree) → -- {{{+            randomCheckpointForTree tree >>= \(_,checkpoint) → return $+                let all_results = exploreTreeStartingFromCheckpoint checkpoint tree+                    maybe_first_result = exploreTreeUntilFirstStartingFromCheckpoint checkpoint tree+                in case maybe_first_result of+                    Nothing → IntSet.null all_results+                    Just result → IntSet.size result == 1 && IntSet.member (IntSet.findMin result) all_results+         -- }}}+        ,testProperty "exploreTreeTUntilFirstStartingFromCheckpoint" $ \(UniqueTree tree) → -- {{{+            randomCheckpointForTree tree >>= \(_,checkpoint) → return $+                let all_results = exploreTreeStartingFromCheckpoint checkpoint tree+                    maybe_first_result = runIdentity $ exploreTreeTUntilFirstStartingFromCheckpoint checkpoint tree+                in case maybe_first_result of+                    Nothing → IntSet.null all_results+                    Just result → IntSet.size result == 1 && IntSet.member (IntSet.findMin result) all_results+         -- }}}+        ,testProperty "exploreTreeUntilFoundStartingFromCheckpoint" $ do -- {{{+            UniqueTree tree ← arbitrary+            (_,checkpoint) ← randomCheckpointForTree tree+            let solutions = exploreTreeStartingFromCheckpoint checkpoint tree+            threshold ← (+1) <$> choose (0,2*IntSet.size solutions)+            return . unsafePerformIO . checkFoundAgainstThreshold threshold solutions $+                exploreTreeUntilFoundStartingFromCheckpoint ((>= threshold) . IntSet.size) checkpoint tree+         -- }}}+        ,testProperty "exploreTreeTUntilFoundStartingFromCheckpoint" $ do -- {{{+            UniqueTree tree ← arbitrary+            (_,checkpoint) ← randomCheckpointForTree tree+            let solutions = exploreTreeStartingFromCheckpoint checkpoint tree+            threshold ← (+1) <$> choose (0,2*IntSet.size solutions)+            return . unsafePerformIO . checkFoundAgainstThreshold threshold solutions . runIdentity $+                exploreTreeTUntilFoundStartingFromCheckpoint ((>= threshold) . IntSet.size) checkpoint tree+          -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Examples" -- {{{+        [testProperty name $ do+            number_of_colors ← choose (2,5)+            number_of_countries ← choose (3,7)+            neighbor_probability ← choose (0,1::Float)+            neighbors ← fmap (concat . concat) $+                forM [1..number_of_countries] $ \x →+                    forM [x+1..number_of_countries] $ \y → do+                        outcome ← choose (0,1)+                        return $+                            if outcome > neighbor_probability+                                then [(x,y),(y,x)]+                                else []+            let solutions =+                    computeSolutions+                        number_of_colors+                        number_of_countries+                        (\x y → (x,y) `elem` neighbors)+            morallyDubiousIOProperty $ do+                forM_ solutions $ \solution →+                    forM_ solution $ \(country_1,color_1) →+                        forM_ solution $ \(country_2,color_2) →+                            when ((country_1,country_2) `elem` neighbors) $+                                assertBool "neighbors have different colors" $ color_1 /= color_2+                let correct_count = sum $ do+                        solution ← zip [1..] <$> replicateM (fromIntegral number_of_countries) [1..number_of_colors]+                        forM_ solution $ \(country_1,color_1) →+                            forM_ solution $ \(country_2,color_2) →+                                when ((country_1,country_2) `elem` neighbors) $+                                    guard $ color_1 /= color_2+                        return 1+                computeCount number_of_colors solutions @?= correct_count+                return True+        | (name,computeSolutions,computeCount) ←+            [("coloringSolutions",coloringSolutions,curry (fromIntegral . length . snd))+            ,("coloringUniqueSolutions",coloringUniqueSolutions,+                \number_of_colors →+                    sum+                    .+                    map (\solution →+                        let number_of_colors_used = maximum . fmap snd $ solution+                        in product [number_of_colors-number_of_colors_used+1..number_of_colors]+                    )+             )+            ]+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Location" -- {{{+        [testProperty "branchingFromLocation . labelFromBranching = id" $ -- {{{+            liftA2 (==)+                (branchingFromLocation . labelFromBranching)+                id+         -- }}}+        ,testProperty "labelFromBranching . branchingFromLocation = id" $ -- {{{+            liftA2 (==)+                (labelFromBranching . branchingFromLocation)+                id+         -- }}}+        ,testGroup "Monoid instance" -- {{{+            [testProperty "equivalent to concatenation of branchings" $ \(parent_branching :: [BranchChoice]) (child_branching :: [BranchChoice]) → -- {{{+                labelFromBranching parent_branching `mappend` labelFromBranching child_branching+                ==+                labelFromBranching (parent_branching `mappend` child_branching)+             -- }}}+            ,testProperty "obeys monoid laws" $ -- {{{+                liftA2 (&&)+                    (liftA2 (==) id (`mappend` (mempty :: Location)))+                    (liftA2 (==) id ((mempty :: Location) `mappend`))+             -- }}}+            ]+         -- }}}+        ,testProperty "Ord instance of Location equivalent to Ord of branching" $ \a b → -- {{{+            (compare `on` branchingFromLocation) a b == compare a b+         -- }}}+        ,testGroup "exploreTreeWithLocations" -- {{{+            [testProperty "same result as exploreTree" $ \(tree :: Tree [()]) →+                 exploreTree ((:[]) <$> tree) == (solutionResult <$> exploreTreeWithLocations tree)+            ]+         -- }}}+        ,testGroup "sendTreeDownLocation" -- {{{+            [testProperty "same result as walking down path" $ do -- {{{+                tree :: Tree Int ← randomTreeWithoutCache+                path ← randomPathForTree tree+                let label = labelFromPath path+                return $+                    sendTreeDownPath path tree+                    ==+                    sendTreeDownLocation label tree+             -- }}}+            ]+         -- }}}+        ,testProperty "exploreLocatableTree" $ -- {{{+            let gen _ 0 = return mzero+                gen label 1 = return (All . (== label) <$> getLocation)+                gen label n = do+                    left_size ← choose (0,n)+                    let right_size = n-left_size+                    left ← gen (leftBranchOf label) left_size+                    right ← gen (rightBranchOf label) right_size+                    return $ left `mplus` right+            in getAll . exploreLocatableTree <$> sized (gen rootLocation)+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Parallel.Adapter.Threads" $ -- {{{+        [testGroup "FirstMode" -- {{{+            [testCase "two threads, one blocked" $ do -- {{{+                RunOutcome _ termination_reason ←+                    Threads.exploreTreeIOUntilFirst+                        (Workgroup.setNumberOfWorkers 2)+                        (liftIO (threadDelay 1) >> endless_tree+                         `mplus`+                         return ()+                        )+                termination_reason @?= Completed (Just (Progress (ChoicePoint Unexplored Explored) ()))+             -- }}}+            ]+         -- }}}+        ,testGroup "FoundModeUsingPull" -- {{{+            [testCase "many threads with combined final result but none finish" $ do -- {{{+                RunOutcome _ termination_reason ←+                    Threads.exploreTreeIOUntilFoundUsingPull+                        ((== 2) . length)+                        (Workgroup.setNumberOfWorkers 4)+                        ((return [1] `mplus` endless_tree) `mplus` (return [2] `mplus` endless_tree))+                case termination_reason of+                    Completed (Right (Progress _ result)) → sort result @?= [1,2]+                    _ → fail $ "got incorrect result: " ++ show termination_reason+             -- }}}+            ]+         -- }}}+        ,testGroup "FoundModeUsingPush" -- {{{+            [testCase "two threads with combined final result but none finish" $ do -- {{{+                RunOutcome _ termination_reason ←+                    Threads.exploreTreeIOUntilFoundUsingPush+                        ((== 2) . length)+                        (Workgroup.setNumberOfWorkers 2)+                        ((return [1] `mplus` endless_tree) `mplus` (return [2] `mplus` endless_tree))+                case termination_reason of+                    Completed (Right (Progress _ result)) → sort result @?= [1,2]+                    _ → fail $ "got incorrect result: " ++ show termination_reason+             -- }}}+            ]+         -- }}}+        ,plusTestOptions (mempty {topt_maximum_generated_tests = Just 10}) $ testGroup "stress tests" $ -- {{{+            let extractResult (RunOutcome _ termination_reason) = -- {{{+                    case termination_reason of+                        Aborted _ → error "prematurely aborted"+                        Completed result → return result+                        Failure _ message → error message+                -- }}}+                insertHooks cleared_flags_mvar request_queue = ($ \id → liftIO $ do -- {{{+                    threadDelay 10+                    mvar ← modifyMVar cleared_flags_mvar $ \cleared_flags →+                        case Map.lookup id cleared_flags of+                            Nothing → do+                                mvar ← newEmptyMVar+                                writeChan request_queue mvar+                                return (Map.insert id mvar cleared_flags,mvar)+                            Just mvar → return (cleared_flags,mvar)+                    readMVar mvar+                 ) -- }}}+                receiveProgressInto progresses_ref progress = atomicModifyIORef progresses_ref ((progress:) &&& const ())+                respondToRequests request_queue generateNoise progresses_ref = do -- {{{+                    Workgroup.setNumberOfWorkers 1+                    forever $ do+                        liftIO $ threadDelay 10+                        mvar ← liftIO $ readChan request_queue+                        liftIO $ threadDelay 10+                        generateNoise $ receiveProgressInto progresses_ref+                        liftIO $ threadDelay 10+                        liftIO $ putMVar mvar ()+                -- }}}+                oneThreadNoise receiveProgress = liftIO (randomRIO (0,1::Int)) >>= \i → case i of -- {{{+                    0 → do Workgroup.setNumberOfWorkers 0+                           Workgroup.setNumberOfWorkers 1+                    1 → void $ requestProgressUpdateAsync receiveProgress+                -- }}}+                twoThreadsNoise receiveProgress = liftIO (randomRIO (0,1::Int)) >>= \i → case i of -- {{{+                    0 → void $ Workgroup.changeNumberOfWorkers (3-)+                    1 → void $ requestProgressUpdateAsync receiveProgress+                -- }}}+                manyThreadsNoise receiveProgress = liftIO (randomRIO (0,2::Int)) >>= \i → case i of -- {{{+                    0 → void $ Workgroup.changeNumberOfWorkers (\i → if i > 1 then i-1 else i)+                    1 → void $ Workgroup.changeNumberOfWorkers (+1)+                    2 → void $ requestProgressUpdateAsync receiveProgress+                -- }}}+            in+            [testGroup "AllMode" $ -- {{{+                let runTest generateNoise = randomUniqueTreeWithHooks >>= \constructTree → morallyDubiousIOProperty $ do+                        cleared_flags_mvar ← newMVar mempty+                        request_queue ← newChan+                        progresses_ref ← newIORef []+                        result ←+                            (Threads.exploreTreeIO+                                (respondToRequests request_queue generateNoise progresses_ref)+                                (insertHooks cleared_flags_mvar request_queue constructTree)+                            ) >>= extractResult+                        let tree = constructTree (const $ return ())+                        correct_result ← exploreTreeT tree+                        result @?= correct_result+                        (remdups <$> readIORef progresses_ref) >>= mapM_ (\(Progress checkpoint result) → do+                            exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree >>= (@?= result)+                            exploreTreeTStartingFromCheckpoint checkpoint tree >>= (@?= correct_result ) . mappend result+                         )+                        return True+              in+              [testProperty "one thread" . runTest $ oneThreadNoise+              ,testProperty "two threads" . runTest $ twoThreadsNoise+              ,testProperty "many threads" . runTest $ manyThreadsNoise+              ]+             -- }}}+            ,testGroup "FirstMode" $ -- {{{+                let runTest generator generateNoise = generator >>= \constructTree → morallyDubiousIOProperty $ do+                        cleared_flags_mvar ← newMVar mempty+                        request_queue ← newChan+                        progresses_ref ← newIORef []+                        maybe_result ←+                            (Threads.exploreTreeIOUntilFirst+                                (respondToRequests request_queue generateNoise progresses_ref)+                                (insertHooks cleared_flags_mvar request_queue constructTree)+                            ) >>= extractResult+                        let tree = constructTree (const $ return ())+                        correct_results ← exploreTreeT tree+                        case maybe_result of+                            Nothing → assertBool "solutions were missed" (IntSet.null correct_results)+                            Just (Progress checkpoint result) → do+                                IntSet.size result @?= 1+                                assertBool "solution was not valid" $ result `IntSet.isSubsetOf` correct_results+                                exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree >>= (@=? result)+                                exploreTreeTStartingFromCheckpoint checkpoint tree >>= (@=? IntSet.difference correct_results result)+                        (remdups <$> readIORef progresses_ref) >>= mapM_ (\checkpoint → do+                            exploreTreeTUntilFirstStartingFromCheckpoint (invertCheckpoint checkpoint) tree >>= (@?= Nothing)+                         )+                        return True+                    testGroupUsingGenerator name generator = testGroup name $+                        [testProperty "one thread" . runTest generator $ oneThreadNoise+                        ,testProperty "two threads" . runTest generator $ twoThreadsNoise+                        ,testProperty "many threads" . runTest generator $ manyThreadsNoise+                        ]+                in [testGroupUsingGenerator "with solutions" randomUniqueTreeWithHooks+                   ,testGroupUsingGenerator "without solutions" randomNullTreeWithHooks+                   ]+             -- }}}+            ,testGroup "FoundModeUsingPull" $ -- {{{+                let runTest generator generateNoise = generator >>= \constructTree → morallyDubiousIOProperty $ do+                        let tree = constructTree (const $ return ())+                        all_results ← exploreTreeT tree+                        number_of_results_to_find ← randomRIO (1,2*IntSet.size all_results)+                        cleared_flags_mvar ← newMVar mempty+                        request_queue ← newChan+                        progresses_ref ← newIORef []+                        result ←+                            (Threads.exploreTreeIOUntilFoundUsingPull+                                ((>= number_of_results_to_find) . IntSet.size)+                                (respondToRequests request_queue generateNoise progresses_ref)+                                (insertHooks cleared_flags_mvar request_queue constructTree)+                            ) >>= extractResult+                        case result of+                            Left incomplete_result → do+                                assertBool "result is not smaller than desired" $ IntSet.size incomplete_result < number_of_results_to_find+                                assertEqual "incomplete result matches all results" incomplete_result all_results+                            Right (Progress checkpoint final_result) → do+                                assertBool "final result is at least as large as desired" $ IntSet.size final_result >= number_of_results_to_find+                                assertBool "final result was not valid" $ final_result `IntSet.isSubsetOf` all_results+                                exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree+                                    >>= assertEqual "final results together do not match all results covered by the checkpoint" final_result+                                exploreTreeTStartingFromCheckpoint checkpoint tree+                                    >>= assertEqual "all results minus final results do not match remaining results" (IntSet.difference all_results final_result)+                        (remdups <$> readIORef progresses_ref) >>= mapM_ (\(Progress checkpoint result) → do+                            exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree >>= (@?= result)+                            exploreTreeTStartingFromCheckpoint checkpoint tree >>= (@?= all_results) . mappend result+                         )+                        return True+                    testGroupUsingGenerator name generator = testGroup name $+                        [testProperty "one thread" . runTest generator $ oneThreadNoise+                        ,testProperty "two threads" . runTest generator $ twoThreadsNoise+                        ,testProperty "many threads" . runTest generator $ manyThreadsNoise+                        ]+                in [testGroupUsingGenerator "with solutions" randomUniqueTreeWithHooks+                   ,testGroupUsingGenerator "without solutions" randomNullTreeWithHooks+                   ]+             -- }}}+            ,testGroup "FoundModeUsingPush" $ -- {{{+                let runTest generator generateNoise = generator >>= \constructTree → morallyDubiousIOProperty $ do+                        let tree = constructTree (const $ return ())+                        all_results ← exploreTreeT tree+                        number_of_results_to_find ← randomRIO (1,2*IntSet.size all_results)+                        cleared_flags_mvar ← newMVar mempty+                        request_queue ← newChan+                        progresses_ref ← newIORef []+                        result ←+                            (Threads.exploreTreeIOUntilFoundUsingPush+                                ((>= number_of_results_to_find) . IntSet.size)+                                (respondToRequests request_queue generateNoise progresses_ref)+                                (insertHooks cleared_flags_mvar request_queue constructTree)+                            ) >>= extractResult+                        case result of+                            Left incomplete_result → do+                                assertBool "result is not smaller than desired" $ IntSet.size incomplete_result < number_of_results_to_find+                                assertEqual "incomplete result matches all results" incomplete_result all_results+                            Right (Progress checkpoint final_result) → do+                                assertBool "result is at least as large as desired" $ IntSet.size final_result >= number_of_results_to_find+                                assertBool "final result was not valid" $ final_result `IntSet.isSubsetOf` all_results+                                exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree+                                    >>= assertEqual "both returned results together do not match all results covered by the checkpoint" final_result+                                exploreTreeTStartingFromCheckpoint checkpoint tree+                                    >>= assertEqual "all results minus return results do not match remaining results" (IntSet.difference all_results final_result)+                        (remdups <$> readIORef progresses_ref) >>= mapM_ (\(Progress checkpoint result) → do+                            exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree >>= (@?= result)+                            exploreTreeTStartingFromCheckpoint checkpoint tree >>= (@?= all_results) . mappend result+                         )+                        return True+                    testGroupUsingGenerator name generator = testGroup name $+                        [testProperty "one thread" . runTest generator $ oneThreadNoise+                        ,testProperty "two threads" . runTest generator $ twoThreadsNoise+                        ,testProperty "many threads" . runTest generator $ manyThreadsNoise+                        ]+                in [testGroupUsingGenerator "with solutions" randomUniqueTreeWithHooks+                   ,testGroupUsingGenerator "without solutions" randomNullTreeWithHooks+                   ]+             -- }}}+            ]+         -- }}}+        ,testCase "processPendingRequests" $ do+            mvar ← newEmptyMVar+            RunOutcome{..} ← Threads.exploreTreeIO (Threads.setNumberOfWorkers 2) $+                let go = processPendingRequests >> liftIO (tryTakeMVar mvar) >>= maybe go return+                in go `mplus` liftIO (putMVar mvar ())+            case runTerminationReason of+                Aborted _ → error "aborted"+                Completed () → return ()+                Failure _ message → error message+            return ()+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Parallel.Common.RequestQueue" -- {{{+        [testCase "kills all controller threads" $ do -- {{{+            starts@[a,b,c,d] ← replicateM 4 newEmptyMVar+            vars@[w,x,y,z] ← replicateM 4 newEmptyMVar+            request_queue ← newRequestQueue+            forkControllerThread request_queue . liftIO $ do+                try (putMVar a () >> forever yield) >>= putMVar w+            forkControllerThread request_queue $ do+                fork (do+                    fork . liftIO $ try (putMVar b () >> forever yield) >>= putMVar x+                    liftIO $ try (putMVar c () >> forever yield) >>= putMVar y+                  :: RequestQueueReader (AllMode ()) () IO ()+                 )+                liftIO $ try (putMVar d () >> forever yield) >>= putMVar z+            forM_ starts $ takeMVar+            killControllerThreads request_queue+            forM_ vars $ \var → do+                value ← takeMVar var+                case value of+                    Right () → assertFailure "Thread did not infinitely loop."+                    Left e →+                        case fromException e of+                            Just ThreadKilled → return ()+                            _ → assertFailure $ "Unexpected exception: " ++ show e+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Parallel.Common.Supervisor" -- {{{+        [testCase "immediately abort" $ do -- {{{+            SupervisorOutcome{..} ← runSupervisor AllMode bad_test_supervisor_actions (UnrestrictedProgram abortSupervisor)+            supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+            supervisorRemainingWorkers @?= ([] :: [Int])+         -- }}}+        ,testCase "failure" $ do -- {{{+            SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode bad_test_supervisor_actions (receiveWorkerFailure () "FAIL" :: ∀ α. SupervisorMonad (AllMode ()) () IO α)+            supervisorTerminationReason @?= SupervisorFailure mempty () "FAIL"+            supervisorRemainingWorkers @?= []+         -- }}}+        ,testGroup "adding and removing workers" -- {{{+            [testGroup "without workload buffer" -- {{{+                [testCase "add one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker ()+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= [()]+                    readIORef maybe_workload_ref >>= (@?= Just ((),entire_workload))+                 -- }}}+                ,testCase "add then remove one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker ()+                        removeWorker ()+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= []+                    readIORef maybe_workload_ref >>= (@?= Just ((),entire_workload)) +                 -- }}}+                ,testCase "add then remove then add one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions) ← addAcceptMultipleWorkloadsAction bad_test_supervisor_actions+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker 1+                        removeWorker 1+                        addWorker 2+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= [2::Int]+                    readIORef maybe_workload_ref >>= (@?= [(1,entire_workload),(2,entire_workload)]) +                 -- }}}+                ,testCase "add two workers then remove first worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions1) ← addAcceptMultipleWorkloadsAction bad_test_supervisor_actions+                    (broadcast_ids_list_ref,actions2) ← addAppendWorkloadStealBroadcastIdsAction actions1+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions2 $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker 1+                        addWorker 2+                        removeWorker 1+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= [2::Int]+                    readIORef maybe_workload_ref >>= (@?= [(1,entire_workload),(2,entire_workload)])+                    readIORef broadcast_ids_list_ref >>= (@?= [[1]])+                 -- }}}+                ,testProperty "add then remove many workers then abort" $ do -- {{{+                    (NonEmpty worker_ids_to_add :: NonEmptyList UUID) ← arbitrary+                    worker_ids_to_remove ←+                       (fmap concat+                        $+                        forM (tail worker_ids_to_add)+                        $+                        \worker_id → do+                            should_remove ← arbitrary+                            if should_remove+                                then return [worker_id]+                                else return []+                        ) >>= shuffle+                    let worker_ids_left = Set.toAscList $ Set.fromList worker_ids_to_add `Set.difference` Set.fromList worker_ids_to_remove +    +                    monadicIO . run $ do+                        (maybe_workload_ref,actions_1) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+                        (broadcast_ids_list_ref,actions_2) ← addAppendWorkloadStealBroadcastIdsAction actions_1+                        SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions_2 $ do+                            enableSupervisorDebugMode+                            setWorkloadBufferSize 0+                            mapM_ addWorker worker_ids_to_add+                            mapM_ removeWorker worker_ids_to_remove+                            abortSupervisor+                        supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                        sort supervisorRemainingWorkers @?= worker_ids_left +                        readIORef maybe_workload_ref >>= (@?= Just (head worker_ids_to_add,entire_workload))+                        readIORef broadcast_ids_list_ref >>= (@?= if (null . tail) worker_ids_to_add then [] else [[head worker_ids_to_add]])+                 -- }}}+                ]+             -- }}}+            ,testGroup "with workload buffer" -- {{{+                [testCase "add one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions1) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+                    (broadcasts_ref,actions2) ← addAppendWorkloadStealBroadcastIdsAction actions1+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions2 $ do+                        enableSupervisorDebugMode+                        addWorker ()+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= [()]+                    readIORef maybe_workload_ref >>= (@?= Just ((),entire_workload))+                    readIORef broadcasts_ref >>= (@?= [[()]])+                 -- }}}+                ,testCase "add then remove one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions1) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+                    (broadcasts_ref,actions2) ← addAppendWorkloadStealBroadcastIdsAction actions1+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions2 $ do+                        enableSupervisorDebugMode+                        addWorker ()+                        removeWorker ()+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= []+                    readIORef maybe_workload_ref >>= (@?= Just ((),entire_workload)) +                    readIORef broadcasts_ref >>= (@?= [[()]])+                 -- }}}+                ,testCase "add then remove then add one worker then abort" $ do -- {{{+                    (maybe_workload_ref,actions1) ← addAcceptMultipleWorkloadsAction bad_test_supervisor_actions+                    (broadcasts_ref,actions2) ← addAppendWorkloadStealBroadcastIdsAction actions1+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions2 $ do+                        enableSupervisorDebugMode+                        addWorker 1+                        removeWorker 1+                        addWorker 2+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                    supervisorRemainingWorkers @?= [2::Int]+                    readIORef maybe_workload_ref >>= (@?= [(1,entire_workload),(2,entire_workload)]) +                    readIORef broadcasts_ref >>= (@?= [[1],[2]])+                 -- }}}+                ]+             -- }}}+            ]+         -- }}}+        ,testGroup "progress updates" -- {{{+            [testCase "request progress update when no workers present" $ do -- {{{+                (maybe_progress_ref,actions) ← addReceiveCurrentProgressAction bad_test_supervisor_actions+                SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions $ do+                    enableSupervisorDebugMode+                    setWorkloadBufferSize 0+                    performGlobalProgressUpdate+                    abortSupervisor+                supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                supervisorRemainingWorkers @?= ([] :: [()])+                readIORef maybe_progress_ref >>= (@?= Just (Progress Unexplored ()))+             -- }}}+            ,testProperty "request progress update when all active workers present leave" $ do -- {{{+                number_of_active_workers ← choose (1,10 :: Int)+                number_of_inactive_workers ← choose (0,10)+                let active_workers = [0..number_of_active_workers-1]+                    inactive_workers = [101..101+number_of_inactive_workers-1]+                monadicIO . run $ do+                    (maybe_progress_ref,actions1) ← addReceiveCurrentProgressAction bad_test_supervisor_actions+                    (broadcast_ids_list_ref,actions2) ← addAppendProgressBroadcastIdsAction actions1+                    (workload_steal_ids_ref,actions3) ← addSetWorkloadStealBroadcastIdsAction actions2+                    let actions4 = ignoreAcceptWorkloadAction $ actions3+                    let progress = Progress Unexplored (Sum 0)+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions4 $ do+                        setWorkloadBufferSize 0+                        addWorker 0+                        forM_ (zip [0..] (tail active_workers)) $ \(prefix_count,worker_id) → do+                            addWorker worker_id+                            [worker_to_steal_from] ← liftIO $ readIORef workload_steal_ids_ref+                            let remaining_workload = Workload (Seq.replicate (prefix_count+1) (ChoiceStep LeftBranch)) Unexplored+                            let stolen_workload = Workload (Seq.replicate (prefix_count) (ChoiceStep LeftBranch) |> (ChoiceStep RightBranch)) Unexplored+                            receiveStolenWorkload worker_to_steal_from $ Just (StolenWorkload (ProgressUpdate mempty remaining_workload) stolen_workload)+                        mapM_ addWorker inactive_workers+                        performGlobalProgressUpdate+                        mapM_ removeWorker active_workers+                        abortSupervisor+                    supervisorTerminationReason @?= SupervisorAborted progress+                    supervisorRemainingWorkers @?= inactive_workers+                    readIORef broadcast_ids_list_ref >>= (@?= [active_workers])+                    readIORef maybe_progress_ref >>= (@?= Just progress)+             -- }}}+            ,testCase "request and receive Just progress update when one worker present" $ do -- {{{+                (maybe_progress_ref,actions1) ← addReceiveCurrentProgressAction bad_test_supervisor_actions+                (broadcast_ids_list_ref,actions2) ← addAppendProgressBroadcastIdsAction actions1+                let actions3 = ignoreAcceptWorkloadAction actions2+                let progress = Progress (ChoicePoint Unexplored Unexplored) (Sum 1)+                SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions3 $ do+                    enableSupervisorDebugMode+                    setWorkloadBufferSize 0+                    addWorker ()+                    performGlobalProgressUpdate+                    receiveProgressUpdate () $ ProgressUpdate progress entire_workload+                    abortSupervisor+                supervisorTerminationReason @?= SupervisorAborted progress+                supervisorRemainingWorkers @?= [()]+                readIORef maybe_progress_ref >>= (@?= Just progress)+                readIORef broadcast_ids_list_ref >>= (@?= [[()]])+             -- }}}+            ,testCase "request and receive progress update when active and inactive workers present" $ do -- {{{+                (maybe_progress_ref,actions1) ← addReceiveCurrentProgressAction bad_test_supervisor_actions+                (broadcast_ids_list_ref,actions2) ← addAppendProgressBroadcastIdsAction actions1+                let actions3 = ignoreAcceptWorkloadAction . ignoreWorkloadStealAction $ actions2+                let progress = Progress (ChoicePoint Unexplored Unexplored) (Sum 1)+                SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions3 $ do+                    enableSupervisorDebugMode+                    setWorkloadBufferSize 0+                    addWorker (1 :: Int)+                    addWorker (2 :: Int)+                    performGlobalProgressUpdate+                    receiveProgressUpdate 1 $ ProgressUpdate progress entire_workload+                    abortSupervisor+                supervisorTerminationReason @?= SupervisorAborted progress+                supervisorRemainingWorkers @?= [1,2]+                readIORef maybe_progress_ref >>= (@?= Just progress)+                readIORef broadcast_ids_list_ref >>= (@?= [[1]])+             -- }}}+            ]+         -- }}}+        ,testGroup "workload steals" -- {{{+            [testCase "failure to steal from a worker leads to second attempt" $ do -- {{{ +                (broadcast_ids_list_ref,actions1) ← addAppendWorkloadStealBroadcastIdsAction bad_test_supervisor_actions+                let actions2 = ignoreAcceptWorkloadAction actions1+                SupervisorOutcome{..} ← runUnrestrictedSupervisor AllMode actions2 $ do+                    addWorker (1::Int)+                    addWorker 2+                    receiveStolenWorkload 1 Nothing+                    abortSupervisor+                supervisorTerminationReason @?= SupervisorAborted (Progress Unexplored ())+                supervisorRemainingWorkers @?= [1,2]+                readIORef broadcast_ids_list_ref >>= (@?= [[1],[1]])+             -- }}}+            ]+         -- }}}+        ,testCase "starting from previous checkpoint" $ do -- {{{+            (maybe_workload_ref,actions1) ← addAcceptOneWorkloadAction bad_test_supervisor_actions+            (broadcast_ids_list_ref,actions2) ← addAppendWorkloadStealBroadcastIdsAction actions1+            let checkpoint = ChoicePoint Unexplored Unexplored+                progress = Progress checkpoint (Sum 1)+            SupervisorOutcome{..} ← runUnrestrictedSupervisorStartingFrom AllMode progress actions2 $ do+                addWorker ()+                abortSupervisor+            supervisorTerminationReason @?= SupervisorAborted progress+            supervisorRemainingWorkers @?= [()]+            readIORef maybe_workload_ref >>= (@?= Just ((),(Workload Seq.empty checkpoint)))+            readIORef broadcast_ids_list_ref >>= (@?= [[()]])+         -- }}}+        ,testGroup "FirstMode" $ -- {{{+            [testGroup "single worker" -- {{{+                [testCase "finishes with Explored" $ do -- {{{+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor FirstMode ignore_supervisor_actions $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker ()+                        receiveWorkerFinished () (Progress Explored Nothing)+                        error "Supervisor did not terminate"+                    supervisorTerminationReason @?= SupervisorCompleted (Nothing :: Maybe (Progress ()))+                 -- }}}+                ,testCase "finishes with result" $ do -- {{{+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor FirstMode ignore_supervisor_actions $ do+                        enableSupervisorDebugMode+                        setWorkloadBufferSize 0+                        addWorker ()+                        receiveWorkerFinished () (Progress Explored (Just ()))+                        error "Supervisor did not terminate"+                    supervisorTerminationReason @?= SupervisorCompleted (Just (Progress Explored ()))+                 -- }}}+                ]+             -- }}}+            ,testGroup "two workers" -- {{{+                [testCase "both finish with Explored" $ do -- {{{+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor FirstMode ignore_supervisor_actions $ do+                        enableSupervisorDebugMode+                        addWorker True+                        addWorker False+                        receiveStolenWorkload True . Just $+                            StolenWorkload+                                (ProgressUpdate+                                    Unexplored+                                    (Workload+                                        (Seq.singleton $ ChoiceStep LeftBranch)+                                        Unexplored+                                    )+                                )+                                (Workload+                                    (Seq.singleton $ ChoiceStep RightBranch)+                                    Unexplored+                                )+                        receiveWorkerFinished True (Progress (ChoicePoint Explored Unexplored) Nothing)+                        receiveWorkerFinished False (Progress (ChoicePoint Unexplored Explored) Nothing)+                        error "Supervisor did not terminate"+                    supervisorTerminationReason @?= SupervisorCompleted (Nothing :: Maybe (Progress ()))+                 -- }}}+                ,testCase "both finish with result" $ do -- {{{+                    SupervisorOutcome{..} ← runUnrestrictedSupervisor FirstMode ignore_supervisor_actions $ do+                        enableSupervisorDebugMode+                        addWorker True+                        addWorker False+                        receiveStolenWorkload True . Just $+                            StolenWorkload+                                (ProgressUpdate+                                    Unexplored+                                    (Workload+                                        (Seq.singleton $ ChoiceStep LeftBranch)+                                        Unexplored+                                    )+                                )+                                (Workload+                                    (Seq.singleton $ ChoiceStep RightBranch)+                                    Unexplored+                                )+                        receiveWorkerFinished False (Progress (ChoicePoint Explored Unexplored) (Just False))+                        receiveWorkerFinished True (Progress (ChoicePoint Unexplored Explored) (Just True))+                        error "Supervisor did not terminate"+                    supervisorTerminationReason @?= SupervisorCompleted (Just (Progress (ChoicePoint Explored Unexplored) False))+                 -- }}}+                ]+             -- }}}+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Parallel.Common.Worker" -- {{{+        [testGroup "forkWorkerThread" -- {{{+            [testCase "abort" $ do -- {{{+                termination_result_ivar ← IVar.new+                semaphore ← newEmptyMVar+                WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                    (IVar.write termination_result_ivar)+                    (liftIO (takeMVar semaphore) `mplus` error "should never get here")+                    entire_workload+                    absurd+                sendAbortRequest workerPendingRequests+                putMVar semaphore ()+                termination_result ← IVar.blocking $ IVar.read termination_result_ivar+                case termination_result of+                    WorkerFinished _ → assertFailure "worker faled to abort"+                    WorkerFailed exception → assertFailure ("worker threw exception: " ++ show exception)+                    WorkerAborted → return ()+                workerInitialPath @?= Seq.empty+                (IVar.nonblocking . IVar.read) workerTerminationFlag >>= assertBool "is the termination flag set?" . isJust+             -- }}}+            ,testGroup "obtains all solutions" -- {{{+                [testProperty "with no initial path" $ \(tree :: Tree [Int]) → unsafePerformIO $ do -- {{{+                    solutions_ivar ← IVar.new+                    _ ← forkWorkerThread AllMode Pure+                            (IVar.write solutions_ivar)+                            tree+                            entire_workload+                            absurd+                    Progress checkpoint solutions ←+                        (IVar.blocking $ IVar.read solutions_ivar)+                        >>=+                        \termination_reason → case termination_reason of+                            WorkerFinished final_progress → return final_progress+                            other → error ("terminated unsuccessfully with reason " ++ show other)+                    checkpoint @?= Explored+                    solutions @?= exploreTree tree+                    return True+                 -- }}}+                ,testProperty "with an initial path" $ \(tree :: Tree [Int]) → randomPathForTree tree >>= \path → return . unsafePerformIO $ do -- {{{+                    solutions_ivar ← IVar.new+                    _ ← forkWorkerThread AllMode Pure+                            (IVar.write solutions_ivar)+                            tree+                            (Workload path Unexplored)+                            absurd+                    Progress checkpoint solutions ←+                        (IVar.blocking $ IVar.read solutions_ivar)+                        >>=+                        \termination_reason → case termination_reason of+                            WorkerFinished final_progress → return final_progress+                            other → error ("terminated unsuccessfully with reason " ++ show other)+                    checkpoint @?= checkpointFromInitialPath path Explored+                    solutions @?= (exploreTree . sendTreeDownPath path $ tree)+                    return True+                 -- }}}+                ]+             -- }}}+            ,testGroup "progress updates correctly capture current and remaining progress" $ -- {{{+                let runAnalysis tree termination_flag termination_result_ivar progress_updates_ref = do -- {{{+                        termination_result ← IVar.blocking $ IVar.read termination_result_ivar+                        remaining_solutions ← case termination_result of+                            WorkerFinished (progressResult → solutions) → return solutions+                            WorkerFailed exception → error ("worker threw exception: " ++ show exception)+                            WorkerAborted → error "worker aborted prematurely"+                        (IVar.nonblocking . IVar.read) termination_flag >>= assertBool "is the termination flag set?" . isJust+                        progress_updates ← reverse <$> readIORef progress_updates_ref+                        let correct_solutions = exploreTree tree+                            update_solutions = map (progressResult . progressUpdateProgress) progress_updates+                            all_solutions = remaining_solutions:update_solutions+                        forM_ (zip [0..] all_solutions) $ \(i,solutions_1) →+                            forM_ (zip [0..] all_solutions) $ \(j,solutions_2) →+                                unless (i == j) $+                                    assertBool "Is there an overlap between non-intersecting solutions?"+                                        (IntSet.null $ solutions_1 `IntSet.intersection` solutions_2)+                        let total_solutions = mconcat all_solutions+                        assertEqual "Are the total solutions correct?"+                            correct_solutions+                            total_solutions+                        let accumulated_update_solutions = scanl1 mappend update_solutions+                        sequence_ $+                            zipWith (\accumulated_solutions (ProgressUpdate (Progress checkpoint _) remaining_workload) → do+                                let remaining_solutions = exploreTreeWithinWorkload remaining_workload tree+                                assertBool "Is there overlap between the accumulated solutions and the remaining solutions?"+                                    (IntSet.null $ accumulated_solutions `IntSet.intersection` remaining_solutions)+                                assertEqual "Do the accumulated and remaining solutions sum to the correct solutions?"+                                    correct_solutions+                                    (accumulated_solutions `mappend` remaining_solutions)+                                assertEqual "Is the checkpoint equal to the the remaining solutions?"+                                    remaining_solutions+                                    (exploreTreeStartingFromCheckpoint checkpoint tree)+                                assertEqual "Is the inverted checkpoint equal to the the accumulated solutions?"+                                    accumulated_solutions+                                    (exploreTreeStartingFromCheckpoint (invertCheckpoint checkpoint) tree)+                             ) accumulated_update_solutions progress_updates+                        return True+                in -- }}}+                [testProperty "continuous progress update requests" $ \(UniqueTree tree) → unsafePerformIO $ do -- {{{+                    starting_flag ← IVar.new+                    termination_result_ivar ← IVar.new+                    WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                        (IVar.write termination_result_ivar)+                        ((liftIO . IVar.blocking . IVar.read $ starting_flag) >> endowTree tree)+                        entire_workload+                        absurd+                    progress_updates_ref ← newIORef []+                    let sendMyProgressUpdateRequest = sendProgressUpdateRequest workerPendingRequests submitProgressUpdate+                        submitProgressUpdate progress_update = do+                            atomicModifyIORef progress_updates_ref ((progress_update:) &&& const ())+                            sendMyProgressUpdateRequest+                    sendMyProgressUpdateRequest+                    IVar.write starting_flag ()+                    runAnalysis tree workerTerminationFlag termination_result_ivar progress_updates_ref+                 -- }}}+                ,testProperty "progress update requests at random leaves" $ \(UniqueTree tree) → unsafePerformIO $ do -- {{{+                    termination_result_ivar ← IVar.new+                    progress_updates_ref ← newIORef []+                    rec WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                            (IVar.write termination_result_ivar)+                            (do value ← endowTree tree+                                liftIO $ randomIO >>= flip when submitMyProgressUpdateRequest+                                return value+                            )+                            entire_workload+                            absurd+                        let submitMyProgressUpdateRequest =+                                sendProgressUpdateRequest+                                    workerPendingRequests+                                    (atomicModifyIORef progress_updates_ref . (&&& const ()) . (:))+                    runAnalysis tree workerTerminationFlag  termination_result_ivar progress_updates_ref+                 -- }}}+                ]+             -- }}}+            ,testCase "terminates successfully with null tree" $ do -- {{{+                termination_result_ivar ← IVar.new+                WorkerEnvironment{..} ←+                    forkWorkerThread AllMode Pure+                        (IVar.write termination_result_ivar)+                        (mzero :: Tree [Int])+                        entire_workload+                        absurd+                termination_result ← IVar.blocking $ IVar.read termination_result_ivar+                case termination_result of+                    WorkerFinished (progressResult → solutions) → solutions @?= mempty+                    WorkerFailed exception → assertFailure ("worker threw exception: " ++ show exception)+                    WorkerAborted → assertFailure "worker prematurely aborted"+                workerInitialPath @?= Seq.empty+                (IVar.nonblocking . IVar.read) workerTerminationFlag >>= assertBool "is the termination flag set?" . isJust+             -- }}}+            ,testGroup "work stealing correctly preserves total workload" $ -- {{{+                let runManyStealsAnalysis tree termination_flag termination_result_ivar steals_ref = do -- {{{+                        termination_result ← IVar.blocking $ IVar.read termination_result_ivar+                        (Progress _ remaining_solutions) ← case termination_result of+                            WorkerFinished final_progress → return final_progress+                            WorkerFailed exception → error ("worker threw exception: " ++ show exception)+                            WorkerAborted → error "worker aborted prematurely"+                        (IVar.nonblocking . IVar.read) termination_flag >>= assertBool "is the termination flag set?" . isJust+                        steals ← reverse <$> readIORef steals_ref+                        let correct_solutions = exploreTree tree+                            prestolen_solutions =+                                map (+                                    progressResult+                                    .+                                    progressUpdateProgress+                                    .+                                    stolenWorkloadProgressUpdate+                                ) steals+                            stolen_solutions =+                                map (+                                    flip exploreTreeWithinWorkload tree+                                    .+                                    stolenWorkload+                                ) steals+                            all_solutions = remaining_solutions:(prestolen_solutions ++ stolen_solutions)+                            total_solutions = mconcat all_solutions+                        forM_ (zip [0..] all_solutions) $ \(i,solutions_1) →+                            forM_ (zip [0..] all_solutions) $ \(j,solutions_2) →+                                unless (i == j) $+                                    assertBool "Is there overlap between non-intersecting solutions?"+                                        (IntSet.null $ solutions_1 `IntSet.intersection` solutions_2)+                        assertEqual "Do the steals together include all of the solutions?"+                            correct_solutions+                            total_solutions+                        let accumulated_prestolen_solutions = scanl1 mappend prestolen_solutions+                            accumulated_stolen_solutions = scanl1 mappend stolen_solutions+                        sequence_ $ zipWith3 (\acc_prestolen acc_stolen (StolenWorkload (ProgressUpdate (Progress checkpoint _) remaining_workload) _) → do+                            let remaining_solutions = exploreTreeWithinWorkload remaining_workload tree+                                accumulated_solutions = acc_prestolen `mappend` acc_stolen+                            assertBool "Is there overlap between the accumulated solutions and the remaining solutions?"+                                (IntSet.null $ accumulated_solutions `IntSet.intersection` remaining_solutions)+                            assertEqual "Do the accumulated and remaining solutions sum to the correct solutions?"+                                correct_solutions+                                (accumulated_solutions `mappend` remaining_solutions)+                            assertEqual "Is the checkpoint equal to the stolen plus the remaining solutions?"+                                (acc_stolen `mappend` remaining_solutions)+                                (exploreTreeStartingFromCheckpoint checkpoint tree)+                         ) accumulated_prestolen_solutions accumulated_stolen_solutions steals+                        return True+                in -- }}}+                [testProperty "single steal" $ \(UniqueTree tree :: UniqueTree) → unsafePerformIO $ do -- {{{+                    reached_position_mvar ← newEmptyMVar+                    blocking_value_ivar ← IVar.new+                    let tree_with_blocking_value =+                            mplus+                                (mplus+                                    (liftIO $ do+                                        _ ← tryPutMVar reached_position_mvar ()+                                        IVar.blocking . IVar.read $ blocking_value_ivar+                                    )+                                    (return (IntSet.singleton 101010101))+                                )+                                (endowTree tree)+                    termination_result_ivar ← IVar.new+                    WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                        (IVar.write termination_result_ivar)+                        tree_with_blocking_value+                        entire_workload+                        absurd+                    maybe_workload_ref ← newIORef Nothing+                    takeMVar reached_position_mvar+                    sendWorkloadStealRequest workerPendingRequests $ writeIORef maybe_workload_ref+                    IVar.write blocking_value_ivar (IntSet.singleton 202020202)+                    Progress _ remaining_solutions ←+                        (IVar.blocking $ IVar.read termination_result_ivar)+                        >>=+                        \termination_result → case termination_result of+                            WorkerFinished final_progress → return final_progress+                            WorkerFailed exception → error ("worker threw exception: " ++ show exception)+                            WorkerAborted → error "worker aborted prematurely"+                    (IVar.nonblocking . IVar.read) workerTerminationFlag >>= assertBool "is the termination flag set?" . isJust+                    StolenWorkload (ProgressUpdate (Progress checkpoint prestolen_solutions) remaining_workload) stolen_workload ←+                        fmap (fromMaybe (error "stolen workload not available"))+                        $+                        readIORef maybe_workload_ref+                    assertBool "Does the checkpoint have unexplored nodes?" $ simplifyCheckpointRoot checkpoint /= Explored+                    exploreTreeTWithinWorkload remaining_workload tree_with_blocking_value >>= (remaining_solutions @?=)+                    exploreTreeTStartingFromCheckpoint (invertCheckpoint checkpoint) tree_with_blocking_value >>= (prestolen_solutions @?=)+                    correct_solutions ← exploreTreeT tree_with_blocking_value+                    stolen_solutions ← exploreTreeTWithinWorkload stolen_workload tree_with_blocking_value+                    correct_solutions @=? mconcat [prestolen_solutions,remaining_solutions,stolen_solutions]+                    assertEqual "There is no overlap between the prestolen solutions and the remaining solutions."+                        IntSet.empty+                        (prestolen_solutions `IntSet.intersection` remaining_solutions)+                    assertEqual "There is no overlap between the prestolen solutions and the stolen solutions."+                        IntSet.empty+                        (prestolen_solutions `IntSet.intersection` stolen_solutions)+                    assertEqual "There is no overlap between the stolen solutions and the remaining solutions."+                        IntSet.empty+                        (stolen_solutions `IntSet.intersection` remaining_solutions)+                    return True+                 -- }}}+                ,testProperty "continuous stealing" $ \(UniqueTree tree) → unsafePerformIO $ do -- {{{+                    starting_flag ← IVar.new+                    termination_result_ivar ← IVar.new+                    WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                        (IVar.write termination_result_ivar)+                        ((liftIO . IVar.blocking . IVar.read $ starting_flag) >> endowTree tree)+                        entire_workload+                        absurd+                    steals_ref ← newIORef []+                    let submitMyWorkloadStealRequest = sendWorkloadStealRequest workerPendingRequests submitStolenWorkload+                        submitStolenWorkload Nothing = submitMyWorkloadStealRequest+                        submitStolenWorkload (Just steal) = do+                            atomicModifyIORef steals_ref ((steal:) &&& const ())+                            submitMyWorkloadStealRequest+                    submitMyWorkloadStealRequest+                    IVar.write starting_flag ()+                    runManyStealsAnalysis tree workerTerminationFlag termination_result_ivar steals_ref+                 -- }}}+                ,testProperty "stealing at random leaves" $ \(UniqueTree tree) → unsafePerformIO $ do -- {{{+                    termination_result_ivar ← IVar.new+                    steals_ref ← newIORef []+                    rec WorkerEnvironment{..} ← forkWorkerThread AllMode io_purity+                            (IVar.write termination_result_ivar)+                            (do value ← endowTree tree+                                liftIO $ randomIO >>= flip when submitMyWorkloadStealRequest+                                return value+                            )+                            entire_workload+                            absurd+                        let submitMyWorkloadStealRequest =+                                sendWorkloadStealRequest+                                    workerPendingRequests+                                    (maybe (return ()) $ atomicModifyIORef steals_ref . (&&& const ()) . (:))+                    runManyStealsAnalysis tree workerTerminationFlag termination_result_ivar steals_ref+                 -- }}}+                ]+             -- }}}+            ]+         -- }}}+        ,testProperty "exploreTreeUntilFirst" $ \(tree :: Tree String) → morallyDubiousIOProperty $ do -- {{{+            termination_reason ← exploreTreeGeneric FirstMode Pure tree+            case termination_reason of+                WorkerFinished maybe_final_progress → return $ (progressResult <$> maybe_final_progress) == exploreTreeUntilFirst tree+                _ → fail $ "returned " ++ show termination_reason ++ " instead of WorkerFinished"+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Path" -- {{{+        [testGroup "sendTreeDownPath" -- {{{+            [testCase "null path" $ (exploreTree . sendTreeDownPath Seq.empty) (return [42]) @?= [42]+            ,testCase "cache" $ do (exploreTree . sendTreeDownPath (Seq.singleton (CacheStep (encode ([42 :: Int]))))) (cache (undefined :: [Int])) @?= [42]+            ,testCase "cacheGuard" $ do (exploreTree . sendTreeDownPath (Seq.singleton (CacheStep (encode ())))) (cacheGuard False >> return [42::Int]) @?= [42]+            ,testCase "choice" $ do -- {{{+                (exploreTree . sendTreeDownPath (Seq.singleton (ChoiceStep LeftBranch))) (return [42] `mplus` undefined) @?= [42]+                (exploreTree . sendTreeDownPath (Seq.singleton (ChoiceStep RightBranch))) (undefined `mplus` return [42]) @?= [42]+             -- }}}+            ,testGroup "errors" -- {{{+                [testGroup "PastTreeIsInconsistentWithPresentTree" -- {{{+                    [testCase "cache step with choice" $ -- {{{+                        try (+                            evaluate+                            .+                            exploreTree+                            $+                            sendTreeDownPath (Seq.singleton (CacheStep undefined :: Step)) (undefined `mplus` undefined :: Tree [Int])+                        ) >>= (@?= Left PastTreeIsInconsistentWithPresentTree)+                     -- }}}+                    ,testCase "choice step with cache" $ -- {{{+                        try (+                            evaluate+                            .+                            exploreTree+                            $+                            sendTreeDownPath (Seq.singleton (ChoiceStep undefined :: Step)) (cache undefined :: Tree [Int])+                        ) >>= (@?= Left PastTreeIsInconsistentWithPresentTree)+                     -- }}}+                    ]+                 -- }}}+                ,testGroup "TreeEndedBeforeEndOfWalk" -- {{{+                    [testCase "mzero" $ -- {{{+                        try (+                            evaluate+                            .+                            exploreTree+                            $+                            sendTreeDownPath (Seq.singleton (undefined :: Step)) (mzero :: Tree [Int])+                        ) >>= (@?= Left TreeEndedBeforeEndOfWalk)+                     -- }}}+                    ,testCase "return" $ -- {{{+                        try (+                            evaluate+                            .+                            exploreTree+                            $+                            sendTreeDownPath (Seq.singleton (undefined :: Step)) (return (undefined :: [Int]))+                        ) >>= (@?= Left TreeEndedBeforeEndOfWalk)+                     -- }}}+                    ]+                 -- }}}+                ]+             -- }}}+            ]+         -- }}}+        ,testGroup "walkThroughTreeT" -- {{{+            [testCase "cache step" $ do -- {{{+                let (transformed_tree,log) =+                        runWriter . sendTreeTDownPath (Seq.singleton (CacheStep . encode $ [24 :: Int])) $ do+                            runAndCache (tell [1] >> return [42 :: Int] :: Writer [Int] [Int])+                log @?= []+                (runWriter . exploreTreeT $ transformed_tree) @?= ([24],[])+             -- }}}+            ,testCase "choice step" $ do -- {{{+                let (transformed_tree,log) =+                        runWriter . sendTreeTDownPath (Seq.singleton (ChoiceStep RightBranch)) $ do+                            lift (tell [1])+                            (lift (tell [2]) `mplus` lift (tell [3]))+                            lift (tell [4])+                            return [42]+                log @?= [1]+                (runWriter . exploreTreeT $ transformed_tree) @?= ([42],[3,4])+             -- }}}+            ]+         -- }}}+        ]+     -- }}}+    ,testGroup "LogicGrowsOnTrees.Utils.PerfectTree" -- {{{+        [Small.testProperty "trivialPerfectTree" . Small.test $ -- {{{+            (liftA2 . liftA2) (==>)+                (\arity _ → arity >= 2)+                ((liftA2 . liftA2) (==)+                    numberOfLeaves+                    ((getWordSum . exploreTree) .* trivialPerfectTree)+                )+         -- }}}+        ]+     -- }}}+    ,testProperty "LogicGrowsOnTrees.Utils.Handle" $ \(x::UUID) → morallyDubiousIOProperty $+        bracket+            (getTemporaryDirectory >>= flip openBinaryTempFile "test-handles")+            (\(filepath,handle) → do+                hClose handle+                removeFile filepath+            )+            (\(_,handle) → do+                send handle x+                hSeek handle AbsoluteSeek 0+                y ← receive handle+                return (x == y)+            )+    ]+-- }}}
+ tutorial/tutorial-1.hs view
@@ -0,0 +1,4 @@+import LogicGrowsOnTrees (exploreTree)+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = print . exploreTree . fmap (:[]) . nqueensUsingBitsSolutions $ 5
+ tutorial/tutorial-10.hs view
@@ -0,0 +1,28 @@+import GHC.Conc (setNumCapabilities)++import LogicGrowsOnTrees.Parallel.Adapter.Threads+    (RunOutcome(..)+    ,TerminationReason(..)+    ,exploreTreeUntilFoundUsingPush+    ,setNumberOfWorkers+    )+import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = do+    setNumCapabilities 2+    RunOutcome statistics termination_reason <-+        exploreTreeUntilFoundUsingPush+            ((>= 5) . length)+            (setNumberOfWorkers 2)+        .+        fmap (:[])+        .+        nqueensUsingBitsSolutions+        $+        10+    case termination_reason of+        Aborted _ -> putStrLn "Search aborted."+        Completed (Left results) -> putStrLn $ "Only found:" ++ show results+        Completed (Right (Progress checkpoint results)) -> putStrLn $ "Found: " ++ show results+        Failure _ message -> putStrLn $ "Failed: " ++ message
+ tutorial/tutorial-11.hs view
@@ -0,0 +1,16 @@+import LogicGrowsOnTrees.Parallel.Adapter.Threads (driver)+import LogicGrowsOnTrees.Parallel.Main (RunOutcome(..),TerminationReason(..),simpleMainForExploreTree)+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))++import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main =+    simpleMainForExploreTree+        driver+        (\(RunOutcome _ termination_reason) -> do+            case termination_reason of+                Aborted _ -> error "search aborted"+                Completed (WordSum count) -> putStrLn $ show count ++ " solutions were found"+                Failure _ message -> error $ "error: " ++ message+        )+        (fmap (const $ WordSum 1) (nqueensUsingBitsSolutions 10))
+ tutorial/tutorial-12.hs view
@@ -0,0 +1,31 @@+import System.Console.CmdTheLine (PosInfo(..),TermInfo(..),defTI,pos,posInfo,required)++import LogicGrowsOnTrees.Parallel.Adapter.Threads (driver)+import LogicGrowsOnTrees.Parallel.Main (RunOutcome(..),TerminationReason(..),mainForExploreTree)+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))++import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main =+    mainForExploreTree+        driver+        (required $+            pos 0+                (Nothing :: Maybe Int)+                posInfo+                  { posName = "BOARD_SIZE"+                  , posDoc = "the size of the board"+                  }+        )+        (defTI+            { termName = "tutorial-11"+            , termDoc = "count the number of n-queens solutions for a given board size"+            }+        )+        (\board_size (RunOutcome _ termination_reason) -> do+            case termination_reason of+                Aborted _ -> error "search aborted"+                Completed (WordSum count) -> putStrLn $ show count ++ " solutions found for board size " ++ show board_size+                Failure _ message -> error $ "error: " ++ message+        )+        (fmap (const $ WordSum 1) . nqueensUsingBitsSolutions . fromIntegral)
+ tutorial/tutorial-2.hs view
@@ -0,0 +1,5 @@+import qualified Data.Sequence as Seq+import LogicGrowsOnTrees (exploreTree)+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = print . exploreTree . fmap Seq.singleton . nqueensUsingBitsSolutions $ 5
+ tutorial/tutorial-3.hs view
@@ -0,0 +1,5 @@+import LogicGrowsOnTrees (exploreTree)+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = print . exploreTree . fmap (const $ WordSum 1) . nqueensUsingBitsSolutions $ 5
+ tutorial/tutorial-4.hs view
@@ -0,0 +1,4 @@+import LogicGrowsOnTrees (exploreTreeUntilFirst)+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = print . exploreTreeUntilFirst . nqueensUsingBitsSolutions $ 10
+ tutorial/tutorial-5.hs view
@@ -0,0 +1,13 @@+import LogicGrowsOnTrees (exploreTreeUntilFound)+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main =+    print+    .+    exploreTreeUntilFound ((>= 3) . length)+    .+    fmap (:[])+    .+    nqueensUsingBitsSolutions+    $+    10
+ tutorial/tutorial-6.hs view
@@ -0,0 +1,25 @@+import GHC.Conc (setNumCapabilities)++import LogicGrowsOnTrees.Parallel.Adapter.Threads+    (RunOutcome(..)+    ,TerminationReason(..)+    ,exploreTree+    ,setNumberOfWorkers+    )+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = do+    setNumCapabilities 2+    RunOutcome statistics termination_reason <-+        exploreTree (setNumberOfWorkers 2)+        .+        fmap (const $ WordSum 1)+        .+        nqueensUsingBitsSolutions+        $+        10+    case termination_reason of+        Aborted progress -> putStrLn "Count aborted."+        Completed (WordSum count) -> putStrLn $ "Found " ++ show count ++ " solutions."+        Failure progress message -> putStrLn $ "Failed: " ++ message
+ tutorial/tutorial-7.hs view
@@ -0,0 +1,45 @@+import Control.Monad.IO.Class (liftIO)+import Data.Monoid (mempty)+import GHC.Conc (setNumCapabilities)+import System.Exit (exitFailure,exitSuccess)++import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Parallel.Adapter.Threads+    (RunOutcome(..)+    ,TerminationReason(..)+    ,abort+    ,exploreTreeStartingFrom+    ,requestProgressUpdate+    ,setNumberOfWorkers+    )+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = setNumCapabilities 2 >> go mempty+ where+  go progress@(Progress _ (WordSum count)) = do+    putStrLn $ "Counting... (starting with " ++ show count ++ " solutions); press <Enter> to abort"+    RunOutcome statistics termination_reason <-+        exploreTreeStartingFrom+            progress+            (do setNumberOfWorkers 2+                _ <- liftIO $ getLine+                _ <- requestProgressUpdate+                abort+            )+        .+        fmap (const $ WordSum 1)+        .+        nqueensUsingBitsSolutions+        $+        14+    case termination_reason of+        Aborted progress -> do+            putStrLn $ "Count aborted; will try again."+            go progress+        Completed (WordSum count) -> do+            putStrLn $ "Found " ++ show count ++ " solutions."+            exitSuccess+        Failure _ message -> do+            putStrLn $ "Failed: " ++ message+            exitFailure
+ tutorial/tutorial-8.hs view
@@ -0,0 +1,34 @@+import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO)+import System.IO (hFlush,stdout)++import LogicGrowsOnTrees.Parallel.Adapter.Threads+    (RunOutcome(..)+    ,TerminationReason(..)+    ,exploreTree+    ,setNumberOfWorkers+    )+import LogicGrowsOnTrees.Utils.WordSum (WordSum(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = do+    RunOutcome _ termination_reason <-+        exploreTree (forever $+            liftIO (do+                putStr "Enter the desired number of workers: "+                hFlush stdout+                readLn+            )+            >>=+            setNumberOfWorkers+        )+        .+        fmap (const $ WordSum 1)+        .+        nqueensUsingBitsSolutions+        $+        14+    case termination_reason of+        Aborted progress -> putStrLn "Count aborted."+        Completed (WordSum count) -> putStrLn $ "Found " ++ show count ++ " solutions."+        Failure _ message -> putStrLn $ "Failed: " ++ message
+ tutorial/tutorial-9.hs view
@@ -0,0 +1,24 @@+import GHC.Conc (setNumCapabilities)++import LogicGrowsOnTrees.Parallel.Adapter.Threads+    (RunOutcome(..)+    ,TerminationReason(..)+    ,exploreTreeUntilFirst+    ,setNumberOfWorkers+    )+import LogicGrowsOnTrees.Checkpoint (Progress(..))+import LogicGrowsOnTrees.Examples.Queens (nqueensUsingBitsSolutions)++main = do+    setNumCapabilities 2+    RunOutcome statistics termination_reason <-+        exploreTreeUntilFirst (setNumberOfWorkers 2)+        .+        nqueensUsingBitsSolutions+        $+        10+    case termination_reason of+        Aborted _ -> putStrLn "Search aborted."+        Completed Nothing -> putStrLn "No result found."+        Completed (Just (Progress checkpoint result)) -> putStrLn $ "Found " ++ show result+        Failure _ message -> putStrLn $ "Failed: " ++ message