packages feed

Advise-me (empty) → 0.1

raw patch · 159 files changed

+28464/−0 lines, 159 filesdep +Advise-medep +Cabaldep +HDBCsetup-changed

Dependencies added: Advise-me, Cabal, HDBC, HDBC-sqlite3, QuickCheck, base, bytestring, containers, convertible, directory, filepath, http-types, ideas, ideas-math-types, lens, mtl, optparse-applicative, parsec, random, semigroups, sqlite-simple, text, time, uniplate, wai, wai-extra, wl-pprint, xlsx

Files

+ Advise-me.cabal view
@@ -0,0 +1,362 @@+name:       Advise-me
+version:    0.1
+synopsis:   Assessment services for the Advise-Me project
+homepage:   http://advise-me.ou.nl/
+
+description:
+
+   The Advise-Me project (Automatic Diagnostics with Intermediate Steps in 
+   Mathematics Education) is a Strategic Partnership in EU’s Erasmus+ programme. 
+   In this project we develop innovative technology for calculating detailed 
+   diagnostics in mathematics education, for domains such as ‘Numbers’ and 
+   ‘Relationships’. The technology is offered as an open, reusable set of 
+   feedback and assessment services. The diagnostic information is calculated 
+   automatically based on the analysis of intermediate steps. For more 
+   information, see the project website or read the EC-TEL 2018 paper 
+   'Fine-grained Cognitive Assessment based on Free-form Input for Math Story 
+   Problems'.
+
+category:            Education
+copyright:           (c) 2019
+license:             Apache-2.0
+Extra-Source-Files:  README.md
+license-file:        LICENSE.txt
+author:              Jorn van Wijk, Ferdinand van Walree, Niels Steenbergen, Wink van Zon, Bastiaan Heeren
+maintainer:          bastiaan.heeren@ou.nl
+stability:           provisional
+build-type:          Simple
+cabal-version:       >= 1.8.0.2
+tested-with:         GHC == 7.10.3
+
+data-files: 
+   networks/labels.xml
+ , networks/CarRental.xdsl
+ , networks/AreaAndExpression.xdsl
+ , networks/Pattern.xdsl
+ , networks/MakingASquare.xdsl
+ , networks/TheatreRate.xdsl
+ , networks/VPattern.xdsl
+ , networks/RectangleArea.xdsl
+ , networks/AreaOfATriangle.xdsl
+ , networks/MagicTrick.xdsl
+ , networks/Matryoshka.xdsl
+ , networks/StudentModel.xdsl
+
+source-repository head
+  type:     svn
+  location: https://ideastest.science.uu.nl/svn/ideas/Tutors/Advise-Me/trunk
+
+-- Support for spreadsheets
+flag xlsx
+  default: True
+
+library
+   hs-source-dirs: 
+      src
+
+   exposed-modules:
+      Bayes.Evidence
+    , Bayes.Factor
+    , Bayes.Inference
+    , Bayes.EliminationOrdering
+    , Bayes.NodeTypes
+    , Bayes.InterfaceWriter
+    , Bayes.Network
+    , Bayes.NetworkReader
+    , Bayes.Script
+    , Bayes.StudentReport
+    , Bayes.SVG
+    , Bayes.Probability
+    , Database.Data
+    , Database.Priors
+    , Domain.LinearAlgebra.Matrix
+    , Domain.Logic.BuggyRules
+    , Domain.Logic.GeneralizedRules
+    , Domain.Logic.Generator
+    , Domain.Logic.InverseRules
+    , Domain.Logic.Parser
+    , Domain.Logic.Rules
+    , Domain.Logic.Strategies
+    , Domain.Logic.Utils
+    , Domain.Logic.Views
+    , Domain.Math.Approximation
+    , Domain.Math.CleanUp
+    , Domain.Math.Data.MultivariatePolynomial
+    , Domain.Math.Equation.BalanceRules
+    , Domain.Math.Equation.CoverUpRules
+    , Domain.Math.Equation.Views
+    , Domain.Math.Numeric.Generators
+    , Domain.Math.Numeric.Rules
+    , Domain.Math.Polynomial.Balance
+    , Domain.Math.Polynomial.BalanceUtils
+    , Domain.Math.Polynomial.BuggyBalance
+    , Domain.Math.Polynomial.BuggyRules
+    , Domain.Math.Polynomial.Examples
+    , Domain.Math.Polynomial.Generators
+    , Domain.Math.Polynomial.LeastCommonMultiple
+    , Domain.Math.Polynomial.RationalRules
+    , Domain.Math.Polynomial.Rules
+    , Domain.Math.Polynomial.Views
+    , Domain.Math.Power.OldViews
+    , Domain.Math.Power.Rules
+    , Domain.Math.Power.Utils
+    , Domain.Math.Power.Views
+    , Domain.Math.Simplification
+    , Domain.Math.SquareRoot.Views
+    , Main.Diagnose
+    , Main.ParserCSV
+    , Main.Report
+    , Main.Tasks
+    , Recognize.Data.Approach
+    , Recognize.Data.Attribute
+    , Recognize.Data.Definition
+    , Recognize.Data.DiagnoseError
+    , Recognize.Data.DiagnoseResult
+    , Recognize.Data.Diagnosis
+    , Recognize.Data.Entry
+    , Recognize.Data.Math
+    , Recognize.Data.MathParserOptions
+    , Recognize.Data.MathParserOutput
+    , Recognize.Data.MathStoryProblem
+    , Recognize.Data.Op
+    , Recognize.Data.RuleId
+    , Recognize.Data.Solution
+    , Recognize.Data.Step
+    , Recognize.Data.StringLexer
+    , Recognize.Data.StringLexerOptions
+    , Recognize.Expr.Functions
+    , Recognize.Expr.Normalform
+    , Recognize.Expr.Symbols
+    , Recognize.Model.Assess
+    , Recognize.Model.Connectives
+    , Recognize.Model.Constraint
+    , Recognize.Model.EvidenceBuilder
+    , Recognize.Model.Result
+    , Recognize.Parsing.Derived
+    , Recognize.Parsing.Interpretation
+    , Recognize.Parsing.MathLexer
+    , Recognize.Parsing.MathParser
+    , Recognize.Parsing.Parse
+    , Recognize.Parsing.Parser
+    , Recognize.Preprocessing
+    , Recognize.Recognizer
+    , Recognize.Strategy.Applications
+    , Recognize.Strategy.Derivation
+    , Recognize.Strategy.Exercises
+    , Recognize.Strategy.Recognizer
+    , Recognize.Strategy.Rules
+    , Recognize.Strategy.Strategies
+    , Recognize.Strategy.Views
+    , Recognize.SubExpr.Compare
+    , Recognize.SubExpr.Functions
+    , Recognize.SubExpr.Recognizer
+    , Recognize.SubExpr.SEParser
+    , Recognize.SubExpr.Symbols
+    , Service.AdviseMe
+    , Service.Sequencer
+    , Service.Types
+    , Task.AreaAndExpression
+    , Task.AreaOfATriangle
+    , Task.CarRental
+    , Task.MagicTrick.Assess
+    , Task.MagicTrick.Recognizer
+    , Task.MakingASquare
+    , Task.Matryoshka.Assess
+    , Task.Matryoshka.Recognizer
+    , Task.Pattern.Assess
+    , Task.Pattern.Recognizer
+    , Task.RectangleArea
+    , Task.TheatreRate.Assess
+    , Task.TheatreRate.Recognizer
+    , Task.VPattern.Assess
+    , Task.VPattern.Recognizer
+    , Util.Cache
+    , Util.Expr
+    , Util.List
+    , Util.Monad
+    , Util.NumberRange
+    , Util.Parentheses
+    , Util.String
+    , Util.Table
+    , Util.TableData
+    , Util.W3CSSHTML
+    , Util.XML
+    , Util.Pretty
+
+   if flag(xlsx)
+      exposed-modules:
+         Database.HumanAssessment
+      build-depends:
+         xlsx >= 0.6.0
+       -- 0.6.0
+       , lens >= 4.15 && < 4.18
+       -- 4.17.1
+       , filepath
+       , text
+       , bytestring
+
+   --other-modules:
+   exposed-modules:
+      Task.Network.AreaAndExpression
+    , Task.Network.AreaOfATriangle
+    , Task.Network.CarRental
+    , Task.Network.MagicTrick
+    , Task.Network.MakingASquare
+    , Task.Network.Matryoshka
+    , Task.Network.Pattern
+    , Task.Network.RectangleArea
+    , Task.Network.StudentModel
+    , Task.Network.TheatreRate
+    , Task.Network.VPattern
+   --autogen-modules: this only works from Cabal 2.0
+   --   Main.NetworkBuilder
+
+   build-depends: 
+      base >= 4.8 && < 5 
+    , ideas >= 1.8
+    , ideas-math-types >= 1.0 
+    , mtl >= 2.2
+    -- 2.2.1
+    , parsec >= 3.1
+    -- 3.1.9
+    , containers >= 0.5
+    -- 0.5.6.2
+    , QuickCheck >= 2.8
+    -- 2.8.1
+    , directory >= 1.2
+    -- 1.2.2.0
+    , wl-pprint >= 1.2
+    -- 1.2.1
+    , uniplate >= 1.6
+    -- 1.6.12
+    , convertible >= 1.1
+    -- 1.1.1.0
+    , HDBC >= 2.4
+    -- 2.4.0.2
+    , HDBC-sqlite3 >= 2.3
+    -- 2.3.3.1
+    , time >= 1.5
+    -- 1.5.0.1
+    , random >= 1.1
+    -- 1.1
+    , semigroups == 0.18.5
+    -- 0.17
+    , sqlite-simple >= 0.4
+    -- 0.4.16.0
+    , Cabal >= 1.22
+    -- 1.22.5.0
+
+
+executable advise-me.cgi
+   main-is: AdviseMe.hs
+   hs-source-dirs: app
+   ghc-options: -Wall
+
+   build-depends: 
+      Advise-me
+    , base
+    , ideas
+    , ideas-math-types
+    , containers
+    , HDBC
+    , HDBC-sqlite3
+    , convertible
+    , mtl 
+    , QuickCheck
+    , directory
+    , wl-pprint 
+    , uniplate 
+    , parsec
+    , random
+    , sqlite-simple
+    , time
+    , optparse-applicative >= 0.14 && < 0.15
+    -- 0.14.3.0
+
+
+executable advise-me-admin.cgi
+   main-is: AdviseMeAdmin.hs
+   hs-source-dirs: app
+   ghc-options: -Wall
+    
+   build-depends: 
+      Advise-me
+    , base
+    , containers
+    , ideas
+    , HDBC
+    , HDBC-sqlite3
+    , convertible
+    , wai >= 3.2.1.1 && < 3.2.3 
+    -- 3.2.2.1
+    , wai-extra == 3.0.22.0 
+    -- 3.0.22.0
+    , bytestring >= 0.10
+    -- 0.10.16.0
+    , directory
+    , filepath >= 1.4
+    -- 1.4.0.0
+    , time >= 1.5
+    -- 1.5.0.1
+    , http-types >= 0.9
+    -- 0.12.3
+
+
+executable database-builder.exe
+   main-is: DatabaseBuilder.hs
+   hs-source-dirs: app
+   ghc-options: -Wall -threaded
+   
+   if flag(xlsx)
+      cpp-options: -DXLSX
+
+   build-depends: 
+      Advise-me
+    , base
+    , filepath
+    , ideas
+    , time
+    , text >= 1.2
+    -- 1.2.1.3
+    , bytestring
+    , containers
+    , mtl
+    , HDBC
+    , HDBC-sqlite3
+    , optparse-applicative
+
+executable report.exe
+   main-is: Report.hs
+   hs-source-dirs: app
+   ghc-options: -Wall
+
+   if flag(xlsx)
+      buildable: True
+   else
+      buildable: False
+
+   build-depends: 
+      Advise-me
+    , base
+    , HDBC-sqlite3
+    , containers
+    , optparse-applicative
+    , wl-pprint
+    , filepath
+
+-- For the test-suite, see the SVN repository
+-- 
+-- test-suite test
+--   type: exitcode-stdio-1.0
+--   hs-source-dirs: tests
+--   main-is: Main.hs
+--   build-depends:
+--      base
+--    , Advise-me
+--    , containers
+--    , ideas
+--    , tasty >= 0.7
+--    , tasty-hunit
+--    , tasty-program
+--    , HDBC-sqlite3
+--    , filepath
+ LICENSE.txt view
@@ -0,0 +1,202 @@+
+                                 Apache License
+                           Version 2.0, January 2004
+                        http://www.apache.org/licenses/
+
+   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+   1. Definitions.
+
+      "License" shall mean the terms and conditions for use, reproduction,
+      and distribution as defined by Sections 1 through 9 of this document.
+
+      "Licensor" shall mean the copyright owner or entity authorized by
+      the copyright owner that is granting the License.
+
+      "Legal Entity" shall mean the union of the acting entity and all
+      other entities that control, are controlled by, or are under common
+      control with that entity. For the purposes of this definition,
+      "control" means (i) the power, direct or indirect, to cause the
+      direction or management of such entity, whether by contract or
+      otherwise, or (ii) ownership of fifty percent (50%) or more of the
+      outstanding shares, or (iii) beneficial ownership of such entity.
+
+      "You" (or "Your") shall mean an individual or Legal Entity
+      exercising permissions granted by this License.
+
+      "Source" form shall mean the preferred form for making modifications,
+      including but not limited to software source code, documentation
+      source, and configuration files.
+
+      "Object" form shall mean any form resulting from mechanical
+      transformation or translation of a Source form, including but
+      not limited to compiled object code, generated documentation,
+      and conversions to other media types.
+
+      "Work" shall mean the work of authorship, whether in Source or
+      Object form, made available under the License, as indicated by a
+      copyright notice that is included in or attached to the work
+      (an example is provided in the Appendix below).
+
+      "Derivative Works" shall mean any work, whether in Source or Object
+      form, that is based on (or derived from) the Work and for which the
+      editorial revisions, annotations, elaborations, or other modifications
+      represent, as a whole, an original work of authorship. For the purposes
+      of this License, Derivative Works shall not include works that remain
+      separable from, or merely link (or bind by name) to the interfaces of,
+      the Work and Derivative Works thereof.
+
+      "Contribution" shall mean any work of authorship, including
+      the original version of the Work and any modifications or additions
+      to that Work or Derivative Works thereof, that is intentionally
+      submitted to Licensor for inclusion in the Work by the copyright owner
+      or by an individual or Legal Entity authorized to submit on behalf of
+      the copyright owner. For the purposes of this definition, "submitted"
+      means any form of electronic, verbal, or written communication sent
+      to the Licensor or its representatives, including but not limited to
+      communication on electronic mailing lists, source code control systems,
+      and issue tracking systems that are managed by, or on behalf of, the
+      Licensor for the purpose of discussing and improving the Work, but
+      excluding communication that is conspicuously marked or otherwise
+      designated in writing by the copyright owner as "Not a Contribution."
+
+      "Contributor" shall mean Licensor and any individual or Legal Entity
+      on behalf of whom a Contribution has been received by Licensor and
+      subsequently incorporated within the Work.
+
+   2. Grant of Copyright License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      copyright license to reproduce, prepare Derivative Works of,
+      publicly display, publicly perform, sublicense, and distribute the
+      Work and such Derivative Works in Source or Object form.
+
+   3. Grant of Patent License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      (except as stated in this section) patent license to make, have made,
+      use, offer to sell, sell, import, and otherwise transfer the Work,
+      where such license applies only to those patent claims licensable
+      by such Contributor that are necessarily infringed by their
+      Contribution(s) alone or by combination of their Contribution(s)
+      with the Work to which such Contribution(s) was submitted. If You
+      institute patent litigation against any entity (including a
+      cross-claim or counterclaim in a lawsuit) alleging that the Work
+      or a Contribution incorporated within the Work constitutes direct
+      or contributory patent infringement, then any patent licenses
+      granted to You under this License for that Work shall terminate
+      as of the date such litigation is filed.
+
+   4. Redistribution. You may reproduce and distribute copies of the
+      Work or Derivative Works thereof in any medium, with or without
+      modifications, and in Source or Object form, provided that You
+      meet the following conditions:
+
+      (a) You must give any other recipients of the Work or
+          Derivative Works a copy of this License; and
+
+      (b) You must cause any modified files to carry prominent notices
+          stating that You changed the files; and
+
+      (c) You must retain, in the Source form of any Derivative Works
+          that You distribute, all copyright, patent, trademark, and
+          attribution notices from the Source form of the Work,
+          excluding those notices that do not pertain to any part of
+          the Derivative Works; and
+
+      (d) If the Work includes a "NOTICE" text file as part of its
+          distribution, then any Derivative Works that You distribute must
+          include a readable copy of the attribution notices contained
+          within such NOTICE file, excluding those notices that do not
+          pertain to any part of the Derivative Works, in at least one
+          of the following places: within a NOTICE text file distributed
+          as part of the Derivative Works; within the Source form or
+          documentation, if provided along with the Derivative Works; or,
+          within a display generated by the Derivative Works, if and
+          wherever such third-party notices normally appear. The contents
+          of the NOTICE file are for informational purposes only and
+          do not modify the License. You may add Your own attribution
+          notices within Derivative Works that You distribute, alongside
+          or as an addendum to the NOTICE text from the Work, provided
+          that such additional attribution notices cannot be construed
+          as modifying the License.
+
+      You may add Your own copyright statement to Your modifications and
+      may provide additional or different license terms and conditions
+      for use, reproduction, or distribution of Your modifications, or
+      for any such Derivative Works as a whole, provided Your use,
+      reproduction, and distribution of the Work otherwise complies with
+      the conditions stated in this License.
+
+   5. Submission of Contributions. Unless You explicitly state otherwise,
+      any Contribution intentionally submitted for inclusion in the Work
+      by You to the Licensor shall be under the terms and conditions of
+      this License, without any additional terms or conditions.
+      Notwithstanding the above, nothing herein shall supersede or modify
+      the terms of any separate license agreement you may have executed
+      with Licensor regarding such Contributions.
+
+   6. Trademarks. This License does not grant permission to use the trade
+      names, trademarks, service marks, or product names of the Licensor,
+      except as required for reasonable and customary use in describing the
+      origin of the Work and reproducing the content of the NOTICE file.
+
+   7. Disclaimer of Warranty. Unless required by applicable law or
+      agreed to in writing, Licensor provides the Work (and each
+      Contributor provides its Contributions) on an "AS IS" BASIS,
+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+      implied, including, without limitation, any warranties or conditions
+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+      PARTICULAR PURPOSE. You are solely responsible for determining the
+      appropriateness of using or redistributing the Work and assume any
+      risks associated with Your exercise of permissions under this License.
+
+   8. Limitation of Liability. In no event and under no legal theory,
+      whether in tort (including negligence), contract, or otherwise,
+      unless required by applicable law (such as deliberate and grossly
+      negligent acts) or agreed to in writing, shall any Contributor be
+      liable to You for damages, including any direct, indirect, special,
+      incidental, or consequential damages of any character arising as a
+      result of this License or out of the use or inability to use the
+      Work (including but not limited to damages for loss of goodwill,
+      work stoppage, computer failure or malfunction, or any and all
+      other commercial damages or losses), even if such Contributor
+      has been advised of the possibility of such damages.
+
+   9. Accepting Warranty or Additional Liability. While redistributing
+      the Work or Derivative Works thereof, You may choose to offer,
+      and charge a fee for, acceptance of support, warranty, indemnity,
+      or other liability obligations and/or rights consistent with this
+      License. However, in accepting such obligations, You may act only
+      on Your own behalf and on Your sole responsibility, not on behalf
+      of any other Contributor, and only if You agree to indemnify,
+      defend, and hold each Contributor harmless for any liability
+      incurred by, or claims asserted against, such Contributor by reason
+      of your accepting any such warranty or additional liability.
+
+   END OF TERMS AND CONDITIONS
+
+   APPENDIX: How to apply the Apache License to your work.
+
+      To apply the Apache License to your work, attach the following
+      boilerplate notice, with the fields enclosed by brackets "[]"
+      replaced with your own identifying information. (Don't include
+      the brackets!)  The text should be enclosed in the appropriate
+      comment syntax for the file format. We also recommend that a
+      file or class name and description of purpose be included on the
+      same "printed page" as the copyright notice for easier
+      identification within third-party archives.
+
+   Copyright [yyyy] [name of copyright owner]
+
+   Licensed under the Apache License, Version 2.0 (the "License");
+   you may not use this file except in compliance with the License.
+   You may obtain a copy of the License at
+
+       http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS,
+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+   See the License for the specific language governing permissions and
+   limitations under the License.
+ README.md view
@@ -0,0 +1,246 @@+Readme+===============================================================================++This file will attempt to detail the assumptions and workflow of the project. +There is a [ticket system](http://ideastest.science.uu.nl/trac) to keep track +of what has been done and what still needs to be done.+++Installation+-------------------------------------------------------------------------------++### GHC++We develop in a bare Haskell Platform environment. Stack is not used at the +moment, due to the complexity of importing local packages that are not yet in +Hackage.++At the moment, the code needs to work with our Ubuntu 16.04 LTS (Xenial) +server, which uses GHC 7.10.3. On that distribution, it should be enough to +do:++    sudo apt install haskell-platform{,-doc,-prof}++On other OSes, the easiest way to get this specific version is perhaps to use +the [generic installer](https://www.haskell.org/platform/):++    wget -O /tmp/hp.tar.gz \+        https://www.haskell.org/platform/download/7.10.3/haskell-platform-7.10.3-unknown-posix-x86_64.tar.gz+    tar xf /tmp/hp.tar.gz+    sudo ./install-haskell-platform.sh++    # We also need to change some flags+    sed -i 's/\(.*"C compiler flags",\s*"\)\(.*\)/\1-fno-PIE \2/g+           ;s/\(.*"C compiler link flags",\s*"\)\(.*\)/\1-no-pie \2/g+           ;s/\(.*"ld flags",\s*"\)\(.*\)/\1-no-pie \2/g' \+           /usr/local/haskell/ghc-7.10.3-x86_64/lib/ghc-7.10.3/settings+++### Database++Since the database is SQLite3, we need the SQLite binary and libraries. On +Debian-based distributions, this amounts to:++    sudo apt install sqlite3 libsqlite3-dev++On Windows, you can get the required executables and DLLs at +[sqlite.org](http://sqlite.org/download.html).++The initial live database can later be built with the `database-builder.exe` +binary, like so:++    ./database-builder.exe -o advise-me.db+++### Web server++To run the binary locally, you can use any web server with CGI support. We can +do the following to use Apache to serve CGI scripts from the +`/usr/lib/cgi-bin` directory on Debian-based distributions:++    sudo apt install apache2+    sudo a2enmod cgid++For other OSes, check this +[guide](https://httpd.apache.org/docs/2.4/howto/cgi.html).++++### Haskell environment++The source code of the project is contained in Git and Subversion +repositories. To obtain it:++    git clone \+        https://github.com/ideas-edu/ideas+    cd ideas; make src/Ideas/Main/Revision.hs; cd -++    svn checkout \+        https://ideastest.science.uu.nl/svn/ideas/Tutors/math-types++    svn checkout \+        https://ideastest.science.uu.nl/svn/ideas/Tutors/Advise-Me/trunk+++Install the sandbox:++    cd trunk+    cabal sandbox init+    cabal sandbox add-source ../ideas+    cabal sandbox add-source ../math-types+    cabal install \+        --only-dependencies \+        --enable-tests \+        --enable-executable-profiling \+        --enable-library-profiling+    cabal configure \+        --enable-tests \+        --enable-executable-profiling \+        --enable-coverage++We use `make`, because there are many different files and interdependencies. +Reading the `Makefile` should give an idea of the workflow. It is also +recommended to make a `config.mk` file, overriding the variables in the +`Makefile` so that they point to the correct directories:++    tee config.mk << EOF+    IDEAS_DIR = ../ideas/src+    MATHTYPES_DIR = ../math-types/src+    CGI_BIN = /usr/lib/cgi-bin+    EOF++++### Bayesian networks++To *create* the Bayesian networks, [Genie](https://www.bayesfusion.com/genie/) +is used. We used to interface with the SMILE library for *using* the networks, +but that is now done in Haskell itself by transforming the original `.xdsl` +files into a Haskell interface. See `network-builder.exe`.+++### Compiling++Now, we can compile the binaries. `make processing` should take care of +everything for us, but of course the binaries can also be created by `cabal` +separately.++Note that there is an `xlsx` cabal flag that is on by default, because +building the `xlsx` library (used for reading human assessments) is not +straightforward on every machine. If you find that the `xlsx` library is +causing issues and you do not need its functionality, do `cabal configure +-flags="-xlsx"` before building.++++Project structure+-------------------------------------------------------------------------------++The following directories are important to know.++- `app/`: Haskell executables and scripts. +- `src/`: Haskell sources to the Advise-Me library.+- `tests/`: Haskell sources to the testing suite.+- `test-data/`: Test input requests for the testing suite and shell scripts to +  send test input to the server.+- `hpc-*`: Haskell code coverage reports as generated by the recipe in the +  Makefile.+- `pilots/`:+    - `raw/`: Databases, mostly untouched as they were collected during pilot +      or evaluation studies.+    - `processed/`: Databases that are created from the raw data after the +      fact, by processing it in various ways using `database-builder.exe`. The +      `Makefile` contains recipes to create these files. +    - `assessments/`: Excel spreadsheets that mirror the names in the +      `processed/` directory. These spreadsheets contain evaluations by humans +      of the same data. They can be used to evaluate or debug the application, +      using `report.exe`, or to change or annotate the processed data. There +      are also documents in this directory that are non-machine readable, +      containing remarks of IDEAS' output by a human examiner.+    - `regressions/`: This directory contains `.exp` files that concatenates +      the expected output of the processed databases. This allows for a +      rudimentary regression test, using `diff`.+- `networks/`: Bayesian networks created in Genie, and a supporting XML file +  containing translations of the labels.++++Apart from the main `advise-me.cgi` binary, there are a couple of auxiliary +binaries to use:++-   The `advise-me.cgi` binary provides the service: you provide `input` via a +    POST or GET request, and it will respond with the information you +    requested. There are also additional commands that can be given to make it +    do other things, like rerunning or reporting. Some of these are +    deprecated, and they aren't documented well.++-   `network-builder.exe` builds, given an `.xdsl` file from `networks/`, the +    interface file necessary for running that network in our Haskell +    environment. Unfortunately, it cannot itself be actually built: it depends +    on the Advise-Me library, which itself depends on the files that it is +    supposed to generate! From `cabal-install` version 2, I believe that we +    could use its autogeneration facilities. For now, as a crutch, we run +    `app/NetworkBuilder.hs` as a script — see the `Makefile`.++-   The `database-builder.exe` binary is a tool to create the initial database +    and process existing databases. It gives us the ability to reuse input +    data collected from a previous run and generate new output for it, as well +    as annotate the database with information tables. As there are many flags +    and switches, call it with `--help` for more info.++++To inspect the resulting databases or to examine statistics, there are +multiple options.++-   `advise-me-admin.cgi` provides a web interface to inspect the databases +    and report on statistics. ++-   `report.exe` can be used offline to compare assessments from IDEAS in the +    database against human assessments with the `humanvsmachine` subcommand. +    It can also count how often evidence occurs with the `priors` subcommand. +    Finally, it can generate a legacy HTML page with diagnostics info, similar +    to the overview in `advise-me-admin.cgi`.++++Testing+-------------------------------------------------------------------------------++Tests that are implemented now relate exclusively to finding the evidence. +Other tests are mostly non-existent, so functionality may break without +warning. (For more fine-grained information on how well the evidence matches +our expectations, see `report.exe`.)++Rudimentary regression tests can be performed with a `diff`, simply to check +whether the output has changed since the last update. `make regressions` does +this for you.++`cabal test` runs the `tasty` test suite with particular example requests, to +check if they still find the evidence we expect. Whenever you fix a specific +bug, please add a test along with the relevant request XML.++++Coverage+-------------------------------------------------------------------------------++To inspect code coverage, do `cabal clean` and `cabal configure +--enable-coverage` and rebuild the binaries that you want to test. After +running the binaries, `.tix` files will be created (that you can optionally +combine with `hpc sum *.tix`). From the `tix` and `mix` files, you can +generate a HTML coverage index or a statistics report. For example:++   hpc report \+      --hpcdir=dist/hpc/vanilla/mix/Advise-me-0.1 \+      --hpcdir=dist/hpc/vanilla/mix/database-builder.exe \+      database-builder.exe.tix+++Profiling+-------------------------------------------------------------------------------++If you have installed the libraries with `--enable-library-profiling` and +configured cabal with `--enable-library-profiling +--enable-executable-profiling`, then you can build a profiling version of the +main CGI binary. The `Makefile` contains a recipe for a PDF report.
+ Setup.hs view
@@ -0,0 +1,14 @@+import Distribution.Simple++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {+   preBuild = \args buildflags -> do+      --buildNetworks -- Ideally, the code from app/NetworkBuilder.exe would be+      --called here, adapted to use the proper buildpath for autogenerated+      --modules. Unfortunately, since it uses the Advise-Me library - the same+      --library that we are trying to build here - we cannot do that at the+      --moment. Therefore, I've set the build-type back to Custom in our cabal+      --configuration. This file won't be used. See #236.+      preBuild simpleUserHooks args buildflags+}+
+ app/AdviseMe.hs view
@@ -0,0 +1,96 @@+module Main (main) where++import Control.Applicative+import Control.Monad+import Main.ParserCSV+import Data.List+import Ideas.Common.Id+import Data.Monoid+import Data.Maybe+import Main.Report+import qualified Main.Diagnose as D+import Options.Applicative+import Options.Applicative.Types+import Recognize.Data.MathStoryProblem+import Main.Tasks+import Service.AdviseMe+import System.Environment+import Util.String++data InputSource = File String+                 | Stdin+ deriving (Show,Eq)++string :: String -> ReadM ()+string s = readerAsk >>= \e -> guard (strToLower e == s)++pExercise :: Parser Task+pExercise = argument (foldl1 (<|>) [ t <$ string (showId t) | t <- tasks ]) argFields+ where+  argFields :: Mod ArgumentFields Task+  argFields = help ("Select an exercise: " ++ intercalate ", " (map showId tasks))+            <> metavar "EXERCISE"++pInputSource :: MathStoryProblem -> Parser InputSource+pInputSource e = pInput (fromMaybe "input/default.csv" (inputFile e))+  where pInput d = File <$> option str (long "file" <> short 'f' <> value d)+                        <|> flag' Stdin (long "stdin" <> short 's')++pDatabase :: Parser FilePath+pDatabase = strArgument argFields+ where+  argFields :: Mod ArgumentFields FilePath+  argFields = help "Provide a database path."+            <> metavar "DATABASE"++pExerciseOptions :: Parser (IO ())+pExerciseOptions = fromM $ do+   Task x <- oneM pExercise+   source <- oneM (pInputSource x)+   return $ print source >>+      case source of+         File s -> if isCSV s+                   then readFileCSV s >>= D.diagnoseMultiple x >>= print+                   else readFile s >>= D.diagnoseSingle x >>= print+         Stdin  -> getContents >>= (\c -> length c `seq` D.diagnoseSingle x c >>= print)+   where isCSV = isSuffixOf "csv"++pReportOptions :: Parser (IO ())+pReportOptions = fromM $ do+   s <- oneM pDatabase+   return $ reportDatabase s "report.html"++pAll :: Parser (IO ())+pAll = pure $ forM_ tasks $ \(Task x) ->+   case inputFile x of+      Just s -> putStrLn ("Exercise:" ++ show x) >> readFileCSV s >>= D.diagnoseMultiple x >>= putStr . indent . show+      _      -> putStrLn ("No default CSV for: " ++ show x)++commands :: Parser (IO ())+commands = hsubparser $+    command "run" (info pExerciseOptions fullDesc)+ <> command "report" (info pReportOptions fullDesc)+ <> command "all" (info pAll fullDesc)+ <> command "help" (info (pure (do+                       putStrLn "Use one of the following commands:"+                       putStrLn "'run [exercise] [input]': Runs the given exercise from input/[exercise].csv, or from a different inputfile given in [input]."+                       putStrLn "([input] can be '-f[filepath]' for file input or '-s' for standard input.)"+                       putStrLn "'all': Runs every exercise from input/[exercise].csv."+                       putStrLn "'report [filepath]': Generates a report on the database given in the filepath to out.html."+                       putStrLn ""+                       putStrLn "Use '--' to access the advise-me service. Examples:"+                       putStrLn "'-- --file=[filepath]': Treats the file given as an xml input request and returns output response to screen."+                       putStrLn "'-- --rerun=[filepath]': Treats the file given as a database and reruns all requests within it."))+                       fullDesc)+ <> help "one of: run, report, all, help"++main :: IO ()+main = do+   args <- getArgs+   let (xs,ys) = unwords args `splitOn` "-- "+       xs' = breaksOn (== ' ') xs+       ys' = breaksOn (== ' ') ys+   if null xs+      then withArgs ys' runService+      else withArgs xs' $+              join $ customExecParser (ParserPrefs "" False True True True 80) (info commands fullDesc)
+ app/AdviseMeAdmin.hs view
@@ -0,0 +1,503 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Main+Description : Produces the CGI binary to the admin module.++Note that we are using an ad-hoc solution to CSV output. Use the @cassava@+package once we need real CSV support.+-}+module Main (main) where++import Data.Monoid ( (<>) )+import Data.Char+import Data.List (sort, isSuffixOf, intersperse, foldl', intersperse)+import Data.Maybe+import Data.String+import Data.Time (formatTime, defaultTimeLocale, UTCTime)+import Control.Monad+import Control.Exception+import Control.Applicative ((<|>))+import Database.HDBC.Sqlite3+import Ideas.Text.HTML hiding (table)+import Ideas.Text.HTML.W3CSS hiding (tag, table, select, input, content)+import Ideas.Text.XML+import qualified Ideas.Text.XML as XML+import Ideas.Utils.Prelude (readM)+import Network.HTTP.Types+import Network.Wai+import System.Directory+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as B+import qualified Ideas.Text.HTML.W3CSS as W3+import qualified Network.Wai.Handler.CGI as CGI++import Bayes.StudentReport (StudentReport, toReport, Competence(..), competences, Translation(..) )+import Bayes.Evidence+import Bayes.Network+import Bayes.NetworkReader+import Bayes.Probability+import Bayes.SVG+import Database.Data+import Util.TableData+import Util.List (orderBy)+import qualified Recognize.Data.MathStoryProblem as MSP+import Main.Tasks ( findTaskFuzzy, taskNetwork )+import Util.String ( percentage, (//) )+import Database.Priors ( Priors(Priors), Prior(Prior), calculatePriors )++data Env = Env+   { binary          :: FilePath+   , database        :: FilePath+   , connection      :: Connection+   , pageType        :: PageType+   }++data Resource+   = HTMLFile HTMLBuilder+   | CSVFile String+   | XMLFile String String++data FileType+   = HTML+   | CSV+   deriving (Show, Read)++data PageType+   = Students+   | Tasks+   | Options+   | Report Bool+   | ModelPage String Int+   | Task String+   | StudentModelsPage FileType+   | SingleRequest Int+++main :: IO ()+main = CGI.run app+++app :: Application+app req respond = do+   env <- makeEnv req+   resource <- (`catch` errorHandler) $ case pageType env of+      StudentModelsPage ft -> studentModelsPage ft env+      Students             -> studentsPage env+      Report ev            -> reportPage ev env+      Tasks                -> tasksPage env+      ModelPage sid i      -> modelPage env sid i+      Task tid             -> taskPage env tid+      Options              -> optionsPage env+      SingleRequest i      -> requestPage env i+   respond $ case resource of+      HTMLFile html -> responseLBS status200+         [ ("Content-Type", "text/html")+         , ("Access-Control-Allow-Origin", "*") ]+         (fromString $ showHTML $ stdPage env html)+      CSVFile csv -> responseLBS status200+         [ ("Content-Type", "text/plain")+         , ("Access-Control-Allow-Origin", "*")+         , ("Content-Disposition"+           , fromString $ "attachment; filename=\"summary-" ++ database env ++ ".csv\"")+         ]+         (fromString csv)+      XMLFile name xml -> responseLBS status200+         [ ("Content-Type", "text/xml")+         , ("Access-Control-Allow-Origin", "*")+         , ("Content-Disposition"+         , fromString $ "attachment; filename=\"" ++ takeWhile (/='.') (database env) ++ "+" ++ name ++ ".xml\"")+         ]+         (fromString xml)+++makeEnv :: Request -> IO Env+makeEnv req = do++   dbs <- findDatabases+   let db = fromMaybe "" $ param "database" <|> listToMaybe dbs+   conn <- if db `elem` dbs+      then connectSqlite3 db+      else return $ error ("Database " ++ db ++ " does not exist.")++   return Env+      { binary = cgiScript+      , database = db+      , connection = conn+      , pageType = case paramString "page" of+         "tasks" -> Tasks+         "options" -> Options+         "students" -> Students+         "studentmodels" -> StudentModelsPage (paramTyped HTML "filetype")+         "task" -> Task (paramString "taskid")+         "model" -> ModelPage (paramString "studentid") (paramTyped 1 "i")+         "report" -> Report (paramFlag "evidence")+         "request" -> SingleRequest (paramTyped 0 "i")+         _ -> Students+      }++   where++   cgiScript :: String -- Is this safe?+   cgiScript = maybe "" B.unpack . lookup "CGI-Script-Name" . requestHeaders $ req++   query :: Query+   query = queryString req++   param :: B.ByteString -> Maybe String+   param = fmap (safeString . maybe "" B.unpack) . flip lookup query++   paramFlag :: B.ByteString -> Bool+   paramFlag = maybe False (const True) . flip lookup query++   paramString :: B.ByteString -> String+   paramString = fromMaybe "" . param++   paramTyped :: Read a => a -> B.ByteString -> a+   paramTyped def = fromMaybe def . (param >=> readM)++   safeString :: String -> String+   safeString = filter (\c -> isAlphaNum c || c `elem` ['.','-','_'])+++findDatabases :: IO [FilePath]+findDatabases = sort . filter (".db" `isSuffixOf`) <$> getDirectoryContents "."++-- | Find the network file associated with a task ID.+findNetwork :: TaskID -> IO FilePath+findNetwork tID = do+   MSP.Task t <- findTaskFuzzy tID+   maybe (error "Could not find network") return $ MSP.networkFile t++urlFor :: Env -> String+urlFor env = binary env ++ B.unpack (renderSimpleQuery True params)++   where+   params :: SimpleQuery+   params = ("database", fromString $ database env) : case pageType env of+      Students             -> [("page", "students")]+      StudentModelsPage ft -> [("page", "studentmodels"), ("filetype", fromString $ show ft)]+      Tasks                -> [("page", "tasks")]+      Options              -> [("page", "options")]+      ModelPage sID i      -> [("page", "model"), ("studentid", fromString sID), ("i", fromString $ show i)]+      Report showEvidence  -> [("page", "report"), ("evidence", "1")]+      Task tID             -> [("page", "task"), ("taskid", fromString tID)]+      SingleRequest i      -> [("page", "request"), ("i", fromString $ show i)] +++++-------------------------------------------------------------------------------+-- * HTML++stdPage :: Env -> HTMLBuilder -> HTMLPage+stdPage env html = addCSS "https://www.w3schools.com/w3css/4/w3.css" $+                   htmlPage "IDEAS Log" $+   W3.container (background Indigo $ mconcat+           [ mkItem Students "Students"+           , mkItem Tasks    "Tasks"+           , mkItem (StudentModelsPage HTML)  "Student models"+           , mkItem (Report False) "All requests"+           , mkItem Options  "Options"+           ]) <>+   W3.container html+ where+   mkItem tp s = button (urlFor env {pageType = tp}) (string s)++errorHandler :: SomeException -> IO Resource+errorHandler = return . HTMLFile . panel . textColor Red . text++table :: Bool -> [[HTMLBuilder]] -> HTMLBuilder+table hasHeader = tableAll . mconcat . zipWith f (hasHeader : repeat False)+ where+   f header = tag "tr" . mconcat . map make+    where+      make | header    = tag "th"+           | otherwise = tag "td"++pageNavBar :: Int -> Env -> (Int -> PageType) -> Int -> HTMLBuilder+pageNavBar nr env pageFor lastPage = fontSize Small $ mconcat $+   [ pageLinkWith 1 False (string "previous")] +++   map pageLink [start .. end] +++   [pageLinkWith lastPage False (string "next")]+ where+   start = (nr-5) `max` 1+   end   = (start+10) `min` lastPage++   pageLink i = pageLinkWith i (i==nr) (text i)+   pageLinkWith i b a =+      button (urlFor env {pageType = pageFor i}) ((if b then background Indigo mempty else mempty) <> a)+++-- | Create a HTML download button.+htmlDownloadCSV :: Env -> HTMLBuilder+htmlDownloadCSV env = button+   (urlFor env {pageType = StudentModelsPage CSV})+   (rounded XL . border . W3.background W3.Blue $ string "download CSV")++-- | Create a prettyprinted HTML link to a student ID.+htmlStudentID :: Env -> String -> HTMLBuilder+htmlStudentID env sID = fontSize Small . bold $ link (urlFor (env {pageType = ModelPage sID 1})) (string sID)++-- | Create a prettyprinted HTML link to a task ID.+htmlTaskID :: Env -> String -> HTMLBuilder+htmlTaskID env tID = fontSize Small . bold $ link (urlFor env {pageType = Task tID}) (string tID)++-- | Create a prettyprinted HTML label.+htmlLabel :: String -> HTMLBuilder+htmlLabel = fontSize Small . bold . string++-- | Create a prettyprinted percentage.+htmlPercentage :: Double -> HTMLBuilder+htmlPercentage = string . percentage 1++-- | Prettyprint information about strategy.+htmlStrategy :: Evidence -> HTMLBuilder+htmlStrategy ev = number ev <> br <> strategies ev++   where+   number :: Evidence -> HTMLBuilder+   number = (<> string " evidence") . bold . text . length . fromEvidence++   strategies :: Evidence -> HTMLBuilder+   strategies+      = spanClass "strategies"+      . mconcat+      . intersperse br+      . map (string . uncurry (state2label taskNetwork))+      . filter (("Strat" `isSuffixOf`) . fst)+      . hardEvidence+++-- ** HTML pages++reportPage :: Bool -> Env -> IO Resource+reportPage showEvidence env = do+   allEntries <- allRecords (connection env)+   humanAssessments <- allHumanAssessments (connection env)+   return . HTMLFile . mconcat . intersperse hr . flip map (grouped allEntries) $+      \(sID, entries) ->+         h2 sID <> (mconcat . intersperse br . map (htmlEntry env humanAssessments showEvidence) $ entries)++   where+   grouped = orderBy ((! "studentid") :: SqlRecord -> String)+++modelPage :: Env -> String -> Int -> IO Resource+modelPage env studentid i = do+   entries <- studentRecords (connection env) studentid+   let n = length entries+   let entry = entries !! ((i `min` n) - 1)++   let sID = entry ! "studentid"+       tID = entry ! "taskid"+       ev = entry ! "evidence" :: Evidence+       sm = entry ! "studentmodel" :: StudentModel+       inputXML = entry ! "input"+       time = entry ! "time" :: UTCTime++   (l1, nw1) <- readNetwork "networks/StudentModel.xdsl"+   (l2, nw2) <- findNetwork (entry ! "taskid") >>= readNetwork+   report <- toReport sID "en" sm++   return $ HTMLFile $+      panel (button (urlFor env { pageType = ModelPage studentid (i+1 `min` n)}) (rounded XL $ border $ marginPos CenterRight $ string "Next")+         <> pageNavBar i env (ModelPage studentid) n <>+         tag "div" (right $ string (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" time))) <>+      h3 ("Inputs for " ++ tID) <>+      mconcat (map (uncurry inputBox) (inputHTMLs inputXML)) <>+      bold (string "Evidence: ") <> text ev <> br <>+      h3 ("Report for " ++ sID) <>+      htmlReport report <>+      h3 ("User model for " ++ sID) <>+      networkToSVG Just l1 (sm `trans` nw1) <>+      h3 ("Task model for " ++ tID) <>+      networkToSVG Just l2 (ev `trans` nw2)+++-- | Create a table representing the student report.+htmlReport :: StudentReport -> HTMLBuilder+htmlReport report = W3.tableAll . mconcat $+      ( tag "tr" . mconcat . map (tag "th") $ [string "Competence", string "Value", string "Visualisation"] ) : +      [ htmlCompetence 0 c | c <- competences report ]++   where ++   htmlCompetence :: Int -> Competence -> HTMLBuilder+   htmlCompetence i c = mconcat $ +      ( tag "tr" . mconcat . map (tag "td") $+            [ spacer i <> (translationLabel $ skillText c), maybe (string "?") htmlPercentage $ skillValue c, skillBar $ (maybe 0.5 id (skillValue c) - 0.5) * 2]+      ) :+      [ htmlCompetence (i+1) c' | c' <- subskills c ]++   spacer :: Int -> HTMLBuilder+   spacer i = tag "span" ("style" .=. ("margin-left:" ++ show (i * 30) ++ "px"))++   skillBar :: Double -> HTMLBuilder+   skillBar d | d < 0  = wrap $ tag "div" ("style" .=. ("display:inline-block;height:20px;background-color:red;border-right:1px solid black;margin-left:" ++ show (maxwidth-width) ++ "px;width:" ++ show width ++ "px;margin-right:"++ show maxwidth ++"px"))+              | d >= 0 = wrap $ tag "div" ("style" .=. ("display:inline-block;height:20px;background-color:green;border-left:1px solid black;margin-left:" ++ show maxwidth ++ "px;width:" ++ show width ++ "px;margin-right:"++ show (maxwidth-width) ++"px"))+      +      where+      maxwidth = 150 :: Integer+      width = round $ 1 + abs d * fromIntegral maxwidth+      wrap x = tag "div" ("style" .=. "float:left;border:1px solid black;" <> x)+++-- | Create a labelled 'input' box.+inputBox :: String -> HTMLBuilder -> HTMLBuilder+inputBox lbl html =+   tag "div" $ background LightGray $ barPos CenterLeft $ panel $+      (tag "div" $ background Indigo $ right $ styleA "position:relative;right:-16px;font-size:0.8em" <> space <> string lbl <> space) <>+      (html)+++-- | Extract the inputIDs and input texts from an entry's XML.+inputHTMLs :: XML.XML -> [(InputID, HTMLBuilder)]+inputHTMLs = map (fmap $ XML.tag "pre"+                       . mconcat+                       . (("style" XML..=. "white-space: pre-wrap"):)+                       . map (either XML.string XML.builder)+                       . content+                       )+           . fromMaybe []+           . collectInputs+++-- | Create a HTML element that represents one request. The request is+-- annotated with the "original" request numbers and can be downloaded as XML.+htmlEntry :: Env -> M.Map (StudentID, TaskID) [(NodeID, Maybe String, Maybe String)] -> Bool -> SqlRecord -> HTMLBuilder+htmlEntry env humanAssessments showEvidence record = +   bold (string $ record ! "taskid") <> +   string (" (request: " ++ findWithDefault "unknown" "original" record ++ ")") <> br <>+   (if showEvidence then tag "div" $ small (bold (string "evidence") <> string ": " <> text (record ! "evidence" :: Evidence) <> mistakesHTML) else mempty) <>+   mconcat (map (uncurry inputBox) (inputHTMLs $ record ! "input")) <>+   button+      (urlFor env {pageType = SingleRequest (record ! "rowid")})+      (rounded XL . border . W3.background W3.Blue $ string "download XML") <> br+   +   where+   mistakes = M.lookup (record ! "studentid", record ! "taskid") humanAssessments++   mistakesHTML = maybe+      (tag "div" $ string "(no human assessment)")+      (tag "div" . mconcat . intersperse (string ", ") . map mistaketoHTML)+      mistakes++   mistaketoHTML (nID, Just x, Nothing) = tag "span" $ textColor Blue (string nID <> string " should be " <> string x)+   mistaketoHTML (nID, x, _) = tag "span" $ textColor Red (string nID <> string " should be " <> maybe (string "empty") string x)+++requestPage :: Env -> Int -> IO Resource+requestPage env i = do+   record <- fromJust <$> recordN (connection env) i +   return $ XMLFile (record ! "original") (record ! "input")+++taskPage :: Env -> String -> IO Resource+taskPage env tID = do+   (l, nw) <- findNetwork tID >>= readNetwork+   records <- taskRecords (connection env) tID+   count <- countStudents (connection env)+   let tbl = makeTable . calculatePriors . records2table $ records+   --let tbl = makeTable nw records++   return $ HTMLFile $+         h1 ("Evidence for " ++ tID) <>+          -- Note: We assume that every student sends at most one request per task+         string (length records `perc` count) <>+         string " of students have sent a request for this task." <>+         htmlTable (italic . string) (bold . string) string tbl <>+         h1 "Task model" <>+         networkToSVG (const Nothing) l nw <>+         h1 "Inputs" <>+         inputBoxes (getInputs records)++   where++   -- | Obtain inputs for all students, grouped by input ID.+   getInputs :: [SqlRecord] -> M.Map InputID [(StudentID, HTMLBuilder)]+   getInputs = flip foldl' mempty $ \m r ->+      foldl'+         (\m' (iID, txt) -> M.insertWith (++) iID [(r ! "studentid", txt)] m')+         m+         (inputHTMLs (r ! "input"))+++   -- | Create input boxes for all input groups.+   inputBoxes :: M.Map InputID [(StudentID, XMLBuilder)] -> HTMLBuilder+   inputBoxes = flip M.foldrWithKey mempty $ \inputID list accumulator ->+      h3 ("Inputs for " ++ inputID) <>+      mconcat (map (uncurry inputBox) list) <>+      accumulator++   perc :: (Show a, Show b, Real a, Real b) => a -> b -> String+   perc x y = show x ++ " of " ++ show y ++ " (" ++ percentage 1 (x // y) ++ ")"++   makeTable :: Priors -> Table String String String+   makeTable (Priors mapping)+      = fromList+      . concatMap (\(nID, Prior p) -> [ ((nID, maybe "Undecided" id lbl), show count) | (lbl, count) <- M.toList p])+      . M.toList+      . M.mapKeysWith mappend snd+      $ mapping+++studentsPage :: Env -> IO Resource+studentsPage env+   = HTMLFile+   . panel+   . htmlTable (htmlStudentID env) (const $ htmlLabel "Number of entries") text+   . fromList+   . map (\(x,y) -> ((x,()),y))+   <$> countStudentEntries (connection env)++++studentModelsPage :: FileType -> Env -> IO Resource+studentModelsPage ft env = do+   tbl <- toTableFromRows (! "studentid") (evStates . (! "studentmodel")) <$> finalRecords (connection env)+   return $ case ft of+      CSV  -> CSVFile $+         csvTable show show (percentage 3) tbl+      HTML -> HTMLFile $+         ( panel $+            styleA "overflow:scroll"+            <> htmlTable (htmlStudentID env) htmlLabel htmlPercentage tbl+         )+         <> htmlDownloadCSV env++++tasksPage :: Env -> IO Resource+tasksPage env+   = HTMLFile+   . panel+   . htmlTable (htmlStudentID env) (htmlTaskID env) htmlStrategy+   . toTable (! "studentid") (! "taskid") (! "evidence")+   <$> allRecords (connection env)++++optionsPage :: Env -> IO Resource+optionsPage env = do+   files <- findDatabases+   times <- mapM getModificationTime files+   return $ HTMLFile $ panel $+      h1 "Database" <>+      table False (zipWith f files times)+ where+   f file time =+      [ (if file == database env then bold else link (urlFor env {database = file})) (string file)+      , text time ]+++-------------------------------------------------------------------------------+-- * Network stuff++trans :: Evidence -> Network () -> Network Probability+trans ev = mapNodes $ \n ->+   let ps = case lookup (nodeId n) (fromEvidenceTp ev) of+               Just (Index i)    -> take (size n) [ if a==i then 1 else 0 | a <- [0..] ]+               Just (Virtual xs) -> map snd xs+               Nothing           -> replicate (size n) 0++   in n { states = zipWith (\(s, _) a -> (s, a)) (states n) ps }
+ app/DatabaseBuilder.hs view
@@ -0,0 +1,770 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, CPP #-}
+{-|
+Module      : Main
+Description : Program for re-building the Advise-Me database offline.
+
+Intended to be used seperately from the main software. It can do the following:
+
+   - Remove double requests and merge those requests which provide inputs for
+     subtasks of the same task.
+   - Rerun the domain reasoner.
+   - Rerun the student models.
+
+-}
+module Main (main) where
+
+import qualified GHC.IO.Encoding as E
+
+
+import Data.Time.Clock (UTCTime)
+import Data.Time.Format (parseTimeM, defaultTimeLocale)
+import Data.List (sortBy, nubBy, foldl', intercalate, isPrefixOf, nub)
+import Data.Char (isSpace)
+import Data.Function (on)
+import Data.Monoid ((<>))
+import Data.Maybe (fromJust, fromMaybe, isJust)
+import Control.Monad (unless, when, forM_, forM)
+import Control.Applicative ((<**>))
+import Control.Arrow ((&&&))
+import Database.HDBC.Sqlite3 (connectSqlite3, setBusyTimeout, Connection)
+import qualified Data.Text as T
+import qualified Data.Map as M
+import qualified Control.Monad.State.Lazy as S
+import qualified Options.Applicative as O
+import qualified Ideas.Text.XML as XML
+--import qualified Ideas.Text.XML.Interface as XML
+import qualified Ideas.Text.UTF8 as WorkaroundUTF8
+import qualified Database.HDBC as SQL
+import qualified Data.ByteString.Char8 as Char8
+import qualified Data.Text.Encoding as T ( decodeLatin1 )
+
+import Ideas.Common.Id (showId)
+
+import Util.NumberRange (NumberRange, range)
+import Util.List (concatMapM, index)
+import Util.String (split, replace, trim, splitOn, strToLower)
+import Main.Tasks (tasks)
+import Main.ParserCSV (readFileCSV)
+import Service.AdviseMe (runDomainReasoner)
+import Bayes.Script ( findEvidence, taskConcepts, aggregateConcepts )
+import Bayes.Evidence (Evidence, evStates)
+import Database.Data
+import System.FilePath ( (</>) )
+
+#ifdef XLSX
+import Database.HumanAssessment ( readEvidence, tally', getSpreadsheet, getHumanMachineFiles, Tally(..), Match(..) )
+#endif
+
+-------------------------------------------------------------------------------
+-- * Interface
+
+data Arguments = Arguments
+   { inDBs :: [FilePath]
+   , outDB :: FilePath
+   , appendFlag :: Bool
+   , generatedEvidence :: Maybe FilePath
+#ifdef XLSX
+   , replaceEvidenceArg :: [FilePath]
+#endif
+   , taskFilterArg :: Maybe [String]
+   , trimFlag :: Bool
+   , collapseFlag :: Bool
+   , fixNumbersFlag :: Bool
+   , drFlag :: Bool
+   , smFlag :: Bool
+   , writeFinalModelsFlag :: Bool
+#ifdef XLSX
+   , writeHumanAssessmentTableFlag :: [FilePath]
+#endif
+   , fixEncodingFlag :: Bool
+   , fixPepiteFlag :: Bool
+   , anonymizeFlag :: Bool
+   }
+
+
+cli :: IO Arguments
+cli = O.execParser $ O.info (args <**> infoArgs <**> O.helper) info
+
+   where
+
+   info :: O.InfoMod Arguments
+   info = O.progDesc "Advise-Me database rebuilder"
+
+   infoArgs =
+      O.infoOption
+         (  "Available tasks: " ++ intercalate ", " taskIDs )
+         (  O.short 'l' <>
+            O.long "list-tasks" <>
+            O.help "List available task IDs"
+         )
+
+   args :: O.Parser Arguments
+   args = Arguments
+      <$>
+         ( O.many . O.strOption $
+            O.short 'i' <> O.long "input" <>
+            O.help "Input database(s)"
+         )
+      <*>
+         ( O.strOption $
+            O.short 'o' <> O.long "output" <>
+            O.help "Output database"
+         )
+      <*>
+         ( O.switch $
+            O.short 'a' <> O.long "append" <>
+            O.help "Whether to overwrite or append to an existing table"
+         )
+      <*>
+         ( O.optional . O.strOption $
+            O.short 'g' <> O.long "generate" <>
+            O.help "Generate simulated students from evidence for tasks in CSV files"
+         )
+#ifdef XLSX
+      <*>
+         ( O.many . O.strOption $
+            O.long "replace-evidence" <>
+            O.help "Replace evidence for existing students with evidence from human-assessed spreadsheet"
+         )
+#endif
+      <*>
+         ( fmap (fmap $ map trim . split ',') . O.optional . O.strOption $
+            O.long "filter" <>
+            O.help "Put requests in the given order; discard all others (expects comma-seperated list of task IDs)"
+         )
+      <*>
+         ( O.switch $
+            O.long "no-empty" <>
+            O.help "Discard input that consist solely of whitespace"
+         )
+      <*>
+         ( O.switch $
+            O.long "collapse" <>
+            O.help "Merge subtask requests and keep only final input"
+         )
+      <*>
+         ( O.switch $
+            O.long "fix-numbers" <>
+            O.help "Update answers to tasks in which numbers have changed; this is a hack to test for regressions with old data"
+         )
+      <*>
+         ( O.switch $
+            O.long "evidence" <>
+            O.help "Rerun the domain reasoner (implies --models)"
+         )
+      <*>
+         ( O.switch $
+            O.long "models" <>
+            O.help "Rerun the task- and student models"
+         )
+      <*>
+         ( O.switch $
+            O.long "models-table" <>
+            O.help "Add a table that details the final student models"
+         )
+#ifdef XLSX
+      <*>
+         ( O.many . O.strOption $
+            O.long "human-assessment-table" <>
+            O.help "Add a table detailing human assessments based on the given spreadsheet(s)"
+         )
+#endif
+      <*>
+         ( O.switch $
+            O.long "fix-encoding" <>
+            O.help "Fix encoding issues: transforms input in ISO-8859-1 to UTF-8"
+         )
+      <*>
+         ( O.switch $
+            O.long "fix-pepite" <>
+            O.help "Fix incorrect Pépite requests"
+         )
+      <*>
+         ( O.switch $
+            O.long "anonymize" <>
+            O.help "Anonymize student data"
+         )
+
+main :: IO ()
+main = do
+   E.setLocaleEncoding E.utf8
+   arg <- cli
+
+   let filterFlag = isJust . taskFilterArg
+       taskFilter = fromMaybe [] $ taskFilterArg arg
+
+   inConns <- mapM connectSqlite3 (inDBs arg)
+
+   -- Test if a students table already exist
+   (anyStudentsTable, allStudentsTable) <- do
+      hasTable <- map ("students" `elem`) <$> mapM SQL.getTables inConns
+      return (or hasTable, and hasTable)
+
+   -- Check for nonsensical commands
+   unless (smFlag arg `implies` (allStudentsTable || drFlag arg)) $
+      error "Cannot run student modeller without evidence. Either run --evidence or make sure your input databases already contain students tables."
+
+   unless ((filterFlag arg) `implies`
+          (not anyStudentsTable || smFlag arg)) $
+      error "Your flags imply that requests may be changed, but your database contains a students table. Also run --models to make sure the models stay consistent."
+
+   forM_ taskFilter $ \tID ->
+      when (not $ tID `elem` taskIDs) $
+         error $ "Task ID \"" ++ tID ++ "\" is not recognized."
+
+   -- Determine the order in which the requests are sent
+   let sortRequests
+        | filterFlag arg  = return . sortBy
+                            (\x y -> compareFilter taskFilter x y
+                                  <> compareTimes x y)
+        | otherwise       = return . sortBy compareAppearance
+
+
+   -- Obtain requests from all databases and perform operations
+   processedRecords <- concatMapM allRecords inConns
+      >>= task "fix encoding"
+         fixEncoding (fixEncodingFlag arg)
+      >>= task "filling in missing information"
+         decorateRequests True
+      >>= task "removing rectanglearea_old"
+         (return . filter (\r -> r ! "taskid" /= "rectanglearea_old")) True
+      >>= task "filtering tasks"
+         (filterTasks taskFilter) (filterFlag arg)
+      >>= task "Anonymizing data"
+         anonymize (anonymizeFlag arg)
+      >>= task "fix Pépite"
+         fixPepite (fixPepiteFlag arg)
+      >>= task "collapsing multiple requests for same task"
+         collapseRequests (collapseFlag arg)
+      >>= task "trimming empty inputs from requests"
+         trimEmptyRequests (trimFlag arg)
+      >>= task "changing numbers in old task answers"
+         changeNumbersInOldRequests (fixNumbersFlag arg)
+      >>= task "determining request order"
+         sortRequests True
+      >>= task "domain reasoner"
+         domainReasoner (drFlag arg)
+#ifdef XLSX
+      >>= task "replacing evidence, drawing from human assessments"
+         (replaceEvidence $ replaceEvidenceArg arg) (length (replaceEvidenceArg arg) > 0)
+#endif
+      >>= task "student modeller"
+         studentModeller (smFlag arg || drFlag arg)
+
+   -- Obtain generated evidence
+   generatedRecords <- maybe (return []) simulateStudents (generatedEvidence arg)
+
+   -- Combine both
+   records <-
+      task "numbering requests"
+         (return . addRequestNumbers) True (processedRecords ++ generatedRecords)
+
+   -- Output connection
+   conn <- connectSqlite3 (outDB arg)
+   setBusyTimeout conn 200
+
+   -- Always write requests table
+   unless (appendFlag arg) $ dropTable conn requestsTable
+   createTable conn requestsTable
+   insertRecords conn requestsTable records
+
+   -- Write students table if we have enough information
+   when (allStudentsTable || drFlag arg || null records) $ do
+      unless (appendFlag arg) $ dropTable conn studentsTable
+      createTable conn studentsTable
+      insertRecords conn studentsTable records
+
+   -- Write final models table
+   when (writeFinalModelsFlag arg) $
+      addModelsTable conn records
+
+#ifdef XLSX
+   -- Write final models table
+   let humanAssessments = writeHumanAssessmentTableFlag arg
+   let allObserved = foldl (\m r -> M.insertWith mappend (r!"studentid",r!"taskid") (r ! "evidence") m) mempty records
+   when (not $ null humanAssessments) $ do
+      tallies <- forM humanAssessments $ \path -> do
+         xlsx <- getSpreadsheet path
+         tally' xlsx allObserved
+      writeHumanAssessmentTable conn . mconcat . concat . map M.elems $ tallies
+#endif
+
+   -- Finalize
+   SQL.commit conn
+   SQL.disconnect conn
+   mapM_ SQL.disconnect inConns
+
+
+-- | Auxiliary: List all possible task IDs.
+taskIDs :: [String]
+taskIDs = map showId tasks
+
+
+-- | Auxiliary: Logical material implication.
+implies :: Bool -> Bool -> Bool
+x `implies` y = not x || y
+
+
+-- | Since there is no way I can see to uniquely identify a record logged by
+-- Ideas, we add request numbers in the following way. This should happen last,
+-- so that we can be certain that the request numbers really correspond to the
+-- correct requests. (In fact, identifying by row ID's will also work since
+-- they should correspond one to one in the live database.)
+addRequestNumbers :: [SqlRecord] -> [SqlRecord]
+addRequestNumbers = zipWith (insert "requestnr") [1 :: Int ..]
+
+
+
+-------------------------------------------------------------------------------
+-- * Sorting functions
+
+-- | Compare records by the index of their task ID w.r.t. the given list.
+compareFilter :: [TaskID] -> SqlRecord -> SqlRecord -> Ordering
+compareFilter taskFilter = compare `on` (index taskFilter . (! "taskid"))
+
+
+-- | Compare records by their logged time.
+compareTimes :: SqlRecord -> SqlRecord -> Ordering
+compareTimes = compare `on` ((! "time") :: SqlRecord -> UTCTime)
+
+
+-- | Compare records by their order of appearance in the original database.
+compareAppearance :: SqlRecord -> SqlRecord -> Ordering
+compareAppearance = compare `on` ((! "rowid") :: SqlRecord -> Integer)
+
+
+
+-------------------------------------------------------------------------------
+-- * Processing steps
+--
+-- Note, in general, that due to laziness the logging messages might not
+-- correspond to actual running time. Perhaps a proper debugging logger would
+-- be helpful.
+
+
+-- | Decorate processing function with information and possibly skip the
+-- function.
+task :: String
+     -> ([SqlRecord] -> IO [SqlRecord])
+     -> Bool
+     -> ([SqlRecord] -> IO [SqlRecord])
+task report function True rows = do
+   putStrLn $ "Running: " ++ report ++ "…"
+   function rows
+task report _ False rows = do
+   putStrLn $ "Skipping: " ++ report ++ "."
+   return rows
+
+
+-- | Discard records for all requests for tasks that are not given as an
+-- argument.
+filterTasks :: [String] -> [SqlRecord] -> IO [SqlRecord]
+filterTasks tIDs = return .  filter (\r -> r ! "taskid" `elem` tIDs)
+
+
+-- | There are three seperate issues that have affected the encoding of pilot
+-- data:
+--
+-- 1. When parsing XML, some HTML entities get transformed to their unescaped
+-- Unicode character counterpart.
+-- 2. When parsing XML, Unicode characters wreak havoc.
+-- 3. When writing XML, it is encoded as ISO-8859-1 rather than UTF-8. This
+-- causes issues since data written to the Sqlite database is assumed to be
+-- UTF-8.
+--
+-- See issue #239 for a description on how these interplay.
+--
+-- Since the pilot data has already been collected, this function re-encodes
+-- the wrongly encoded Unicode characters, after which they are replaced with
+-- corresponding HTML entities. For future data, this should not be necessary:
+-- we should always use UTF-8, we should never auto-unescape, and we should
+-- either always expect escaped characters, or understand Unicode.
+fixEncoding :: [SqlRecord] -> IO [SqlRecord]
+fixEncoding records = do
+   forM records $ \record ->
+      let input = addCodepoints . fixEntities . T.unpack . T.decodeLatin1 . Char8.pack $ record ! "input"
+      in do
+         --mapM putChar (filter (\x -> not $ x == '\10' || x >= ' ' || x <= '~') input)
+         return . insert "input" input $ record
+
+   where
+   -- | Temporary solution to solve issue #240 & #253. The issue was that
+   -- parseXML expects a string without actual Unicode characters - not a
+   -- bytestring, but one that only contains Unicode code points nonetheless,
+   -- which it will try to decode. This is wrong and should change in later
+   -- versions of IDEAS, but for now we will encode the string to avoid issues.
+   addCodepoints :: String -> String
+   addCodepoints = id --WorkaroundUTF8.encode
+
+   -- | Fix HTML entities DWO sent wrong. (see issue #242)
+   fixEntities :: String -> String
+   fixEntities = flip (foldr ($)) $ map (uncurry replace)
+      [ ("&lt;;","&lt;") -- This is super hacky, but so is the problem itself
+      , ("&lt","&lt;")
+      ]
+
+
+-- | Add identifying information that is not logged by Ideas. Clearly, this is
+-- not an ideal solution, but it will do for now.
+decorateRequests :: [SqlRecord] -> IO [SqlRecord]
+decorateRequests = mapM $ \record ->
+   let  input = record ! "input"
+        (sID,tID) = fromJust . collectIDs $ input
+        iIDs = intercalate "," . map fst . fromJust . collectInputs $ input
+        rID = range [record ! "rowid"]
+   in return
+         . insert "inputs" iIDs
+         . insert "studentid" sID
+         . insert "taskid" tID
+         . insert "original" rID
+         $ record
+
+
+-- | Translate student IDs to anonymized IDs.
+anonymize :: [SqlRecord] -> IO [SqlRecord]
+anonymize records = 
+   let translation :: M.Map String String
+       translation = M.fromList $ zip (nub $ map (! "studentid") records) (map show [1..])
+   in forM records $ \record -> do
+      let sID' = translation M.! (record ! "studentid")
+      return $ insert "studentid" sID'
+             . insert "input" (setID sID' $ record ! "input")
+             . insert "output" (setID sID' $ record ! "output")
+             $ record
+
+   where
+   setID :: String -> XML.XML -> XML.XML
+   setID sID = XML.foldXML (\t as cs -> XML.makeXML t . mconcat $ map (mkAttr' sID) as ++ map (either XML.string XML.builder) cs) id id
+
+   mkAttr' :: String -> XML.Attribute -> XML.XMLBuilder
+   mkAttr' sID ("userid" XML.:= _) = "userid" XML..=. sID
+   mkAttr' sID ("user" XML.:= _) = "user" XML..=. sID
+   mkAttr' sID (n XML.:= a) = n XML..=. a
+
+-- | Collapse subtasks, such that every student/task pair has only a single
+-- request, namely, a merger of all requests for that pair.
+collapseRequests :: [SqlRecord] -> IO [SqlRecord]
+collapseRequests records = do
+   --forM records $ \record -> do
+   --   mapM (\x -> putStrLn $ show x ++ show (fromEnum x)) (record ! "input" :: String)
+   --   print $ XML.parseXML (record ! "input")
+   -- Extract decorated records and reinsert the XML
+   let collapsed = map (uncurry $ insert "input") . M.elems
+                 -- Map student/task pairs to decorated records
+                 . foldl' (\m e -> M.insertWith merger (getKey e) e m) M.empty
+                 -- Decorate each record with its XML, to avoid re-parsing it on every merge
+                 . map ((! "input") &&& id)
+                 $ records
+   putStrLn $ "Collapsed " ++ show (length records) ++ " records into " ++ show (length collapsed) ++ "."
+   return collapsed
+
+   where
+   merger (newXML, r1) (oldXML, r2) = (fromJust $ mergeRequest newXML oldXML, mergeIDs r1 r2)
+
+   getKey :: (XML.XML, SqlRecord) -> (StudentID, TaskID)
+   getKey = fromJust . collectIDs . fst
+
+   -- keep the rightmost record but merge its id with the left record
+   mergeIDs :: SqlRecord -> SqlRecord -> SqlRecord
+   mergeIDs x y = insert "original" (x ! "original" <> y ! "original" :: NumberRange) x
+
+   -- Merge two request XMLs such that the result contains the inputs of both,
+   -- but is otherwise identical to the one in the first argument.
+   mergeRequest :: Monad m => XML.XML -> XML.XML -> m XML.XML
+   mergeRequest new old = do
+      new' <- collectInputs new
+      old' <- collectInputs old
+      return . replaceInputs new
+             . map (Right . snd)
+             . sortBy (compare `on` fst)
+             . nubBy ((==) `on` fst)
+             $ new' ++ old'
+
+mkAttr (n XML.:= a) = n XML..=. a
+mkContent f = either XML.string (XML.builder . f)
+
+-- | Auxiliary: Remove the inputs from a request and replace them with the
+-- given inputs.
+replaceInputs :: XML.XML -> [Either String XML.XML] -> XML.XML
+replaceInputs xml inputs = XML.foldXML foldRequest id id xml
+
+   where 
+
+   mkXML :: XML.Name -> [XML.Attribute] -> [Either String XML.XML] -> XML.XML
+   mkXML t as cs = XML.makeXML t . mconcat $ map mkAttr as ++ map (mkContent id) cs
+
+   foldRequest "request" as cs = XML.makeXML "request" . mconcat $ map mkAttr as ++ map (mkContent $ XML.foldXML foldSolution id id) cs
+   foldRequest t as cs = mkXML t as cs
+   
+   foldSolution "solution" as cs = XML.makeXML "solution" . mconcat $ map mkAttr as ++ map (mkContent id) inputs
+   foldSolution t as cs = mkXML t as cs
+
+
+-- | Trim requests that are empty or consist exclusively of whitespace.
+trimEmptyRequests :: [SqlRecord] -> IO [SqlRecord]
+trimEmptyRequests records = do
+   let trimmed = [ insert "input" (replaceInputs request $ map Right inputs') record
+                 | record <- records
+                 , let request = record ! "input"
+                 , inputs <- map snd <$> collectInputs request
+                 , let inputs' = filter (not . isEmpty . XML.content) inputs
+                 , not (null inputs') ]
+   putStrLn $ "Trimmed " ++ show (length records) ++ " records into " ++ show (length trimmed)
+   return trimmed
+
+   where
+
+   isEmpty :: [Either String XML.XML] -> Bool
+   isEmpty (Left s:xs) = all isSpace s && isEmpty xs
+   isEmpty (Right _:_) = False
+   isEmpty [] = True
+
+
+-- | Sometimes, tasks are updated just to the extent that the numbers change.
+-- In order for the tests for those tasks to remain usable, we change the input
+-- fo the pilot data in such a way that any number that would have been
+-- recognized beforehand is changed to the new number. Of course, this is far
+-- from bulletproof,  but the data will be worth more than if we didn't do it.
+changeNumbersInOldRequests :: [SqlRecord] -> IO [SqlRecord]
+changeNumbersInOldRequests = return . map maybeChange
+
+   where
+
+   maybeChange :: SqlRecord -> SqlRecord
+   maybeChange r | condition "carrental" "2019-01-01" r = adjust "input" carrental . adjust "original" (++"*") $ r
+                 | condition "matryoshka" "2019-01-01" r = adjust "input" matryoshka . adjust "original" (++"*") $ r
+                 | otherwise = r
+
+   condition :: TaskID -> String -> SqlRecord -> Bool
+   condition tID day r =
+      r ! "taskid" == tID &&
+      r ! "time" < (fromJust $ parseTimeM False defaultTimeLocale "%Y-%m-%d" day :: UTCTime)
+
+   carrental :: String -> String
+   carrental string = foldr (uncurry replace) string
+      [ ("93.8", "92.0")
+      , ("93,8", "92,0")
+      , ("19.5", "20.0")
+      , ("19,5", "20,0")
+      , ("42.95", "43.0")
+      , ("42,95", "43,0")
+      , ("23.45", "23.0")
+      , ("23,45", "23,0")]
+
+   matryoshka :: String -> String
+   matryoshka string = replace " 6 " " 5 " string
+
+
+
+-- | Fix input in Pépite database, where requests don't always conform to what
+-- IDEAS expects (see issues #257 and #258). 
+-- This is unreadable, but it's just a hack for the FR-201905* pilots
+fixPepite :: [SqlRecord] -> IO [SqlRecord]
+fixPepite records = do
+   forM records $ \record -> do
+      let input = record ! "input"
+      source <- collectSource input
+      if source /= "pepite"
+         then return record
+         else do
+            (_, tID) <- collectIDs input
+            inputs <- map snd <$> collectInputs input
+            let inputs' = ($ inputs) $ stripv0 . 
+                  case tID of
+                     "makingasquare" -> transformIDs [("1","01")]
+                     "matryoshka" -> transformIDs [("1","02")]
+                     "carrental" -> transformIDs [("1","03")]
+                     "pattern" -> transformIDs [("1","04")]
+                     "magictrick" -> transformIDs [("1","05")]
+                     "rectanglearea" -> transformIDs [("1","06a"), ("2","06b"), ("3","06c")] . separate
+                     "theatrerate" -> transformIDs [("1","07a"),("3","07b")]
+                     "areaandexpression" -> fixMatrix
+                     "areaofatriangle" -> transformIDs [("1","09a"), ("2","09b"),("3","09c")] . separate
+                     "vpattern" -> transformIDs [("1","10")]
+            let input' = replaceInputs input $ map Right inputs'
+            return $ insert "input" input' record
+
+
+   where
+
+   -- | Remove occurrences of the string "v0"
+   stripv0 :: [XML.XML] -> [XML.XML]
+   stripv0 = map (XML.foldXML (\t as cs -> XML.makeXML t . mconcat $ map mkAttr as ++ map (either (XML.string . replace "v0" "") XML.builder) cs) id id )
+
+   -- Turn string like 000100010 into expected inputs. Third and last boolean are meaningless.
+   fixMatrix :: [XML.XML] -> [XML.XML]
+   fixMatrix [] = []
+   fixMatrix [xml] = 
+      let string = XML.getData xml 
+      in map (\(i,v) -> XML.makeXML "input" . mconcat $ [ "id" XML..=. ['0','8',i], (if v == '1' then XML.string "true" else XML.string "false")]) $
+            if length string == 9 && all (`elem` ['0','1']) string
+               then zip ['a'..] (take 2 string ++ take 5 (drop 3 string)) 
+               else []
+
+   -- | Change names of inputs according to given translation.
+   transformIDs :: [(InputID, InputID)] -> [XML.XML] -> [XML.XML]
+   transformIDs ids = map $ \xml -> 
+      let f t as cs = XML.makeXML t . mconcat $ map (mkAttr . g) as ++ map (mkContent id) cs
+          g ("id" XML.:= i) = "id" XML.:= fromMaybe "no-identifier" (lookup i ids) 
+          g other = other
+      in XML.foldXML f id id xml
+
+   -- | Separate inputs at the word "question" and give them a corresponding
+   -- ID.
+   separate :: [XML.XML] -> [XML.XML]
+   separate xmls = 
+      case xmls of
+         [xml] -> 
+            map (
+               XML.makeXML (XML.name xml) 
+               . mconcat 
+               . (\(i,cs) -> ("id" XML..=. i) : map (either XML.string XML.builder) cs)
+            )
+            . reverse
+            . sepAtQuestion [("1",[])]
+            $ XML.content xml
+         _ -> error "There shouldn't be more than one child to be separated"
+
+      where
+      sepAtQuestion :: [(InputID, [Either String XML.XML])] -> [Either String XML.XML] -> [(InputID, [Either String XML.XML])]
+      sepAtQuestion all@((identifier,content):rest) elements = case elements of
+         [] -> all
+         Right x:xs -> sepAtQuestion ((identifier,content ++ [Right x]):rest) xs
+         Left x:xs -> case strToLower x `splitOn` "question" of
+            ("","") -> all
+            ("", y') -> sepAtQuestion all (Left y':xs)
+            (x', y') -> case dropWhile isSpace y' of
+               '3':z' -> sepAtQuestion (("3",[]):(identifier,content ++ [Left x']):rest) (Left z':xs)
+               '2':z' -> sepAtQuestion (("2",[]):(identifier,content ++ [Left x']):rest) (Left z':xs)
+               '1':z' -> sepAtQuestion ((identifier,content ++ [Left x']):rest) (Left z':xs)
+               z' -> sepAtQuestion ((identifier,content ++ [Left x']):rest) (Left z':xs)
+               
+
+-- | Process the records through the AdviseMe Domain Reasoner and update the
+-- 'output' and 'evidence' columns accordingly.
+--
+-- TODO: Also update the responsetime column.
+domainReasoner :: [SqlRecord] -> IO [SqlRecord]
+domainReasoner = mapM $ \record -> do
+   reply <- runDomainReasoner $ record ! "input"
+   evidence <- 
+      if hasError reply
+         then do
+            putStrLn $ "Warning: Ideas replied with an error: \n" ++ reply
+            return mempty
+         else do
+            xmlReply <- either fail return $ XML.parseXML reply
+            findEvidence xmlReply
+   return . insert "output" reply
+          . insert "evidence" evidence
+          $ record
+
+-- | Crude way of establishing whether IDEAS' reply contained an error.
+hasError :: String -> Bool
+hasError = ("<reply result=\"error\"" `isPrefixOf`)
+
+
+-- | Replace evidence in records with evidence extracted from spreadsheets
+-- (only if XLSX flag is set).
+replaceEvidence :: [FilePath] -> [SqlRecord] -> IO [SqlRecord]
+#ifdef XLSX
+replaceEvidence paths records = do
+   evidenceTable <- foldr (M.unionWith (<>)) mempty <$> mapM readEvidence paths
+   return . flip map records $ \record ->
+      maybe record (flip (insert "evidence") record) 
+         (M.lookup (record ! "studentid", record ! "taskid") evidenceTable) 
+#else
+replaceEvidence = undefined
+#endif
+
+
+-- | Build the student model for every record.
+studentModeller :: [SqlRecord] -> IO [SqlRecord]
+studentModeller records = flip S.evalStateT mempty $
+   forM records $ \r -> do
+      let sID = r ! "studentid"    :: String
+          tID = r ! "taskid"       :: String
+          ev  = r ! "evidence"     :: Evidence
+      otherPartialModels <- S.gets (M.findWithDefault mempty sID)
+      let partialModel = taskConcepts tID ev
+      let allPartialModels' = M.insert tID partialModel otherPartialModels
+      let studentModel = aggregateConcepts (M.toList allPartialModels')
+      S.modify $ M.insert sID allPartialModels'
+      return . insert "studentmodel" studentModel 
+             . insert "partialmodel" partialModel
+             $ r
+
+
+-- | Record all final models in a seperate table.
+addModelsTable :: Connection -> [SqlRecord] -> IO ()
+addModelsTable conn records = do
+   dropTable conn modelsTable
+   createTable conn modelsTable
+   insertRecords conn modelsTable (map asModel finalRecords')
+
+   where
+
+   -- Only keep the final record of each student
+   finalRecords'
+      = filter (\r -> (/= "") . SQL.fromSql $ r ! "studentmodel")
+      . reverse
+      . nubBy ((==) `on` ((! "studentid") :: SqlRecord -> String))
+      . reverse
+      $ records
+
+   nodeNames = map fst . evStates . SQL.fromSql $ head finalRecords' ! "studentmodel"
+
+   -- Turn a student record into a model record
+   asModel rec = M.fromList $
+      ("studentid", rec ! "studentid") :
+      (map (fmap SQL.toSql) . evStates . SQL.fromSql $ rec ! "studentmodel")
+
+   modelsTable = SqlTable
+      { tableName = "final_models"
+      , columns = ("studentid", "TEXT") : map (\x -> (x, "REAL")) nodeNames
+      }
+
+#ifdef XLSX
+-- | Record human assessments in a separate table.
+writeHumanAssessmentTable :: Connection -> Tally -> IO ()
+writeHumanAssessmentTable conn tally = do
+   dropTable conn assessmentTable
+   createTable conn assessmentTable
+   insertRecords conn assessmentTable (map asMatch $ expectedPresence tally ++ expectedAbsence tally ++ mismatchState tally)
+
+   where
+   -- Turn a student record into a model record
+   asMatch m = M.fromList $ 
+      [("studentid", SQL.toSql $ locStudent m)
+      , ("taskid", SQL.toSql $ locTask m)
+      , ("nodeid", SQL.toSql $ locNode m)
+      , ("expected", SQL.toSql $ expectation m)
+      , ("observed", SQL.toSql $ observation m)] 
+   
+   assessmentTable = SqlTable
+      { tableName = "assessment"
+      , columns = [("studentid", "TEXT"), ("taskid", "TEXT"), ("nodeid", "TEXT"), ("expected","TEXT"), ("observed","TEXT")]
+      }
+#endif
+
+
+
+
+-------------------------------------------------------------------------------
+
+-- | Make simulated students out of a CSV file with columns containing evidence
+-- for every (!) task.
+simulateStudents :: FilePath -> IO [SqlRecord]
+simulateStudents file = do
+   putStrLn "Generating entries for simulated evidence..."
+   (keys:values) <- readFileCSV file
+   let sIDs = map (("simulation" ++) . show) [1 :: Int ..]
+   let students = zip sIDs $ map (M.fromList . zip keys) values
+   studentModeller
+      [ insert "studentid" sID
+      . insert "taskid" tID
+      . insert "evidence" (row M.! tID)
+      . insert "input" "generated student"
+      $ defaultEntry [studentsTable, requestsTable]
+      | tID <- filter (/= "rectanglearea_old") taskIDs
+      , (sID, row) <- students ]
+ app/Report.hs view
@@ -0,0 +1,204 @@+--{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import System.FilePath ( (</>) )+import Data.Monoid ( (<>) )+import Control.Monad ( forM )+import qualified Data.Map as M+import qualified Database.HDBC.Sqlite3 as SQL ( connectSqlite3 )+import qualified Options.Applicative as O+import qualified Text.PrettyPrint.Leijen as PP+import Text.PrettyPrint.Leijen ( pretty, (<+>), (<$$>) )++import Main.Report (reportDatabase)+import Database.Priors ( calculatePriors )+import Database.HumanAssessment ( summarise, summariseTasks, getHumanMachineFiles, tally, mismatchState, expectedAbsence, prettyMatches )+import Database.Data ( PilotID, TaskID, NodeID, allEvidence )+import Util.Pretty ( prettyMap )+++-- Filter pilot IDs.+filterPilots :: [PilotID] -> [(PilotID, a, b)] -> [(PilotID, a, b)]+filterPilots [] = id+filterPilots ps = filter (\(p,_,_) -> p `elem` ps)+++-- | Filter node IDs.+filterNodes :: [NodeID] -> M.Map (TaskID, NodeID) m -> M.Map (TaskID, NodeID) m+filterNodes [] = id+filterNodes ns = M.filterWithKey (\(_,n) _ -> n `elem` ns)+++-- | Filter task IDs.+filterTasks :: [TaskID] -> M.Map (TaskID, NodeID) m -> M.Map (TaskID, NodeID) m+filterTasks [] = id+filterTasks ts = M.filterWithKey (\(t,_) _ -> t `elem` ts)+++data Command +   = PriorsCommand PriorsArguments+   | HumanVsMachineCommand HumanVsMachineArguments+   | OutFileCommand OutFileArguments++data OutFileArguments = OutFileArguments+   { inDB :: FilePath+   , outHTML :: FilePath+   }++data PriorsArguments = PriorsArguments+   { priorsDatabases :: [FilePath]+   }++data HumanVsMachineArguments = HumanVsMachineArguments+   { humanDir :: FilePath+   , machineDir :: FilePath+   , pilots :: [PilotID] +   , tasks :: [TaskID] --htmlOutput :: Maybe FilePath+   , nodes :: [NodeID]+   , showTotals :: Bool+   , analysisFlag :: Bool+   }++cli :: IO Command --Arguments+cli = O.execParser $ O.info (O.helper <*> commands) (O.progDesc "Advise-Me reporter and performance analysis tool")++   where++   commands :: O.Parser Command+   commands = O.hsubparser $ +      O.command "priors" priorsParser <> +      O.command "humanvsmachine" humanVsMachineParser <>+      O.command "outfiles" outFileParser++   outFileParser :: O.ParserInfo Command+   outFileParser = OutFileCommand <$> O.info (O.helper <*> outFileArgs) (O.progDesc "make a HTML report (legacy)")++   outFileArgs :: O.Parser OutFileArguments+   outFileArgs = OutFileArguments <$>+         ( O.strOption $+            O.short 'i' <> O.long "input" <>+            O.help "Input database"+         )+         <*>+         ( O.strOption $+            O.short 'o' <> O.long "output" <>+            O.help "Output file" <> O.value "out.html"+         )+++   priorsParser :: O.ParserInfo Command+   priorsParser = PriorsCommand <$> O.info (O.helper <*> priorsArgs) (O.progDesc "calculation of node priors")++   priorsArgs :: O.Parser PriorsArguments+   priorsArgs = PriorsArguments <$> databaseFiles++   databaseFiles =+         ( O.some . O.strOption $ +            O.short 'f' <> O.long "file" <>+            O.help "database file(s) to consider"+         )++   humanVsMachineParser :: O.ParserInfo Command+   humanVsMachineParser = HumanVsMachineCommand <$> O.info (O.helper <*> humanVsMachineArgs) (O.progDesc "human-vs-machine comparison")++   humanVsMachineArgs :: O.Parser HumanVsMachineArguments+   humanVsMachineArgs = HumanVsMachineArguments+      <$>+         ( O.strOption $+            O.long "human-directory" <>+            O.help "Directory containing the human assessments" <>+            O.value ("pilots" </> "assessments")+         )+      <*>+         ( O.strOption $+            O.long "machine-directory" <>+            O.help "Directory containing the machine assessments" <>+            O.value ("pilots" </> "processed")+         )+      <*>+         ( O.many . O.strOption $+            O.short 'p' <> O.long "pilot" <>+            O.help "Consider only the given pilots"+         )+      <*>+         ( O.many . O.strOption $+            O.short 't' <> O.long "task" <>+            O.help "Consider only the given tasks"+         )+      <*>+         ( O.many . O.strOption $+            O.short 'n' <> O.long "node" <>+            O.help "Consider only the given nodes"+         )+      <*>+         ( O.switch $+            O.short 's' <> O.long "node-summary" <>+            O.help "Show summary value for nodes per task"+         )+      <*> ( O.switch $+            O.short 'a' <> O.long "analysis" <>+            O.help "Show overview of mismatches"+          )++main :: IO ()+main = do+   cmd <- cli+   case cmd of+      PriorsCommand args -> mainPriors args+      HumanVsMachineCommand args -> mainHumanVsMachine args+      OutFileCommand args -> mainOutFiles args+++mainOutFiles :: OutFileArguments -> IO ()+mainOutFiles arg = reportDatabase (inDB arg) (outHTML arg)+++mainPriors :: PriorsArguments -> IO ()+mainPriors args = do+   priors <- fmap (foldr (<>) mempty) . forM (priorsDatabases args) $ \path -> +      calculatePriors <$> (SQL.connectSqlite3 path >>= allEvidence)+   PP.putDoc $+      pretty "Priors:" <$$>+      pretty priors <$$>+      mempty+++-- | Looks for spreadsheets with human assessments of the pilot data (in the+-- @tests/human-scored@ directory), and shows how they compare against the+-- machine assessments.+mainHumanVsMachine :: HumanVsMachineArguments -> IO ()+mainHumanVsMachine arg = do+   files <- filterPilots (pilots arg) <$> getHumanMachineFiles (machineDir arg) (humanDir arg)+   tallies' <- mapM (\(_,s,d) -> tally s d) files++   let tallies = filterNodes (nodes arg)+               . filterTasks (tasks arg)+               . foldl (M.unionWith (<>)) mempty+               $ tallies'+   let stally = summarise tallies++   let prettyTallies' = if showTotals arg +         then prettyMap $ summariseTasks tallies +         else prettyMap $ tallies++   PP.putDoc $ +      PP.text "Considering pilots:" <+> +      PP.hsep (map (\(p,_,_) -> PP.text p) files) <$$> +      mempty <$$>+      pretty "Tallies:" <$$>+      prettyTallies' <$$>+      pretty "Summary:" <$$> +      pretty stally <$$>+      mempty++   putStrLn ""++   if not $ analysisFlag arg +      then mempty+      else PP.putDoc $+         pretty "Contradictions:" <$$>+         mempty <$$>+         prettyMatches (mismatchState stally ++ expectedAbsence stally)++   putStrLn ""+
+ networks/AreaAndExpression.xdsl view
@@ -0,0 +1,84 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="L_shape" />
+			<state id="T_shape" />
+			<probabilities>0.5 0.5</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step11">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.245 0.745 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step12">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.245 0.745 0.01</probabilities>
+		</cpt>
+		<noisyadder id="R1212_T09">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step11 Ans1Strat1Step12</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step11 Ans1Strat1Step12</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>247 275 329 326</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="R1212_T09">
+				<name>Set up geometric model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>249 161 333 217</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="Ans1Strat1Step11">
+				<name>Answer (0,1,0; 0,1,1; 0,1,0)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>102 125 150 155</position>
+				<barchart active="true" width="162" height="72" />
+			</node>
+			<node id="Ans1Strat1Step12">
+				<name>Answer: (0,0,0; 1,1,1; 0,1,0)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>449 131 497 161</position>
+				<barchart active="true" width="181" height="72" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>263 44 311 74</position>
+				<barchart active="true" width="140" height="54" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/AreaOfATriangle.xdsl view
@@ -0,0 +1,342 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<probabilities>0.5 0.5 0</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<probabilities>0.4 0.6 0</probabilities>
+		</cpt>
+		<noisyadder id="R1212_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans2Strat1Step1</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1213_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans2Strat1Step1</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step2</parents>
+			<probabilities>0.95 0.05 0.05 0.95 0.5 0.5</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat">
+			<state id="Algebraic" />
+			<state id="Numeric" />
+			<probabilities>0.72 0.28</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat Ans1Strat1Step2 Ans2Strat1Step2</parents>
+			<probabilities>0.695 0.295 0.01 0.395 0.595 0.01 0.5 0.4 0.1 0.395 0.595 0.01 0.295 0.695 0.01 0.4 0.5 0.1 0.5 0.4 0.1 0.4 0.5 0.1 0.4 0.4 0.2 0.008999999999999999 0.001 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.001 0.008999999999999999 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat1Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat1Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat1Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat Ans1Strat1Step2 Ans2Strat1Step2</parents>
+			<probabilities>0.008999999999999999 0.001 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.001 0.008999999999999999 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.695 0.295 0.01 0.395 0.595 0.01 0.5 0.4 0.1 0.395 0.595 0.01 0.295 0.695 0.01 0.4 0.5 0.1 0.5 0.4 0.1 0.4 0.5 0.1 0.4 0.4 0.2</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat2Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans3Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans3Strat2Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans3Strat1Step3 Ans3Strat2Step3</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R12_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat1Step1</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R3222_T08">
+			<state id="Correctr" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans2Strat1Step2</parents>
+			<probabilities>0.95 0.05 0.05 0.95 0.5 0.5</probabilities>
+		</cpt>
+		<noisyadder id="R3221_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R321_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat2Step1 Ans3Strat2Step2</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R323_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R324_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat1Step3</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Q1 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>118 279 200 330</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>10x/2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>205 98 253 128</position>
+				<barchart active="true" width="104" height="72" />
+			</node>
+			<node id="Ans2Strat1Step1">
+				<name>2(x+3)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>473 92 521 122</position>
+				<barchart active="true" width="107" height="72" />
+			</node>
+			<node id="Ans3Strat2Step1">
+				<name>Try &lt;n&gt; != 2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>476 377 524 407</position>
+				<barchart active="true" width="114" height="72" />
+			</node>
+			<node id="Ans2Strat1Step2">
+				<name>Answer: &quot;2x+6&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>473 207 521 237</position>
+				<barchart active="true" width="107" height="72" />
+			</node>
+			<node id="Ans3Strat1Step1">
+				<name>5x=2x+6</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>207 384 255 414</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="Ans3Strat">
+				<name>Q3 Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>323 445 405 496</position>
+				<barchart active="true" width="148" height="54" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>Answer: &quot;5x&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>208 206 256 236</position>
+				<barchart active="true" width="104" height="72" />
+			</node>
+			<node id="Ans3Strat2Step2">
+				<name>Try &lt;n&gt; == 2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>475 492 523 522</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="Ans3Strat2Step3">
+				<name>Answer: &quot;2&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>483 599 531 629</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="Ans3Strat1Step2">
+				<name>3x=6</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>205 497 253 527</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="R323_T08">
+				<name>Simplify by addition and subtraction</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>49 546 144 608</position>
+				<barchart active="true" width="119" height="69" />
+			</node>
+			<node id="R324_T08">
+				<name>Simplify by multiplication and division</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>54 653 145 716</position>
+				<barchart active="true" width="138" height="69" />
+			</node>
+			<node id="Ans2">
+				<name>Q2 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>572 287 654 338</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans3">
+				<name>Q3 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>336 689 418 740</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="R3221_T08">
+				<name>Expand expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>564 144 678 184</position>
+				<barchart active="true" width="97" height="70" />
+			</node>
+			<node id="Ans3Strat1Step3">
+				<name>Answer: &quot;2&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>209 599 257 629</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="R3222_T08">
+				<name>Divide out common factors</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>54 134 148 190</position>
+				<barchart active="true" width="110" height="70" />
+			</node>
+			<node id="R1212_T08">
+				<name>Set up geometric model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>325 20 409 76</position>
+				<barchart active="true" width="104" height="68" />
+			</node>
+			<node id="R1213_T08">
+				<name>Set up linear model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>329 159 399 213</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="R12_T08">
+				<name>Set up algebraic equations</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>58 401 132 464</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R321_T08">
+				<name>Substitute</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>592 425 659 463</position>
+				<barchart active="true" width="107" height="54" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/CarRental.xdsl view
@@ -0,0 +1,361 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic" />
+			<state id="Numerical" />
+			<probabilities>0.79 0.21</probabilities>
+			<property id="DSL_OUTCOME_ORDER">1</property>
+		</cpt>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.595 0.395 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step3Path">
+			<state id="Equation" />
+			<state id="Inequality" />
+			<probabilities>0.6 0.4</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step31">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2 Ans1Strat1Step3Path</parents>
+			<probabilities>0.7 0.29 0.01 0.005 0.005 0.99 0.29 0.7 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step41">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step31</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step51">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step41</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step32">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2 Ans1Strat1Step3Path</parents>
+			<probabilities>0.005 0.005 0.99 0.6 0.39 0.01 0.005 0.005 0.99 0.19 0.8 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step42">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step32</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step52">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step42</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1Strat1Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step52 Ans1Strat1Step51</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.0004999999999999449 0.0004999999999999449 0.999</parameters>
+		</noisymax>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.595 0.395 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat2Step3 Ans1Strat1Step6</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R1211_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1213_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R12_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step31</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R323_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step41 Ans1Strat1Step42</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R324_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step51 Ans1Strat1Step52</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R11_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step1 Ans1Strat2Step2</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R31_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step2 Ans1Strat2Step1</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R13_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step32</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>509 760 591 811</position>
+				<barchart active="true" width="116" height="60" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>c=20+0.25*d</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>245 207 293 237</position>
+				<barchart active="true" width="138" height="82" />
+			</node>
+			<node id="Ans1Strat1Step31">
+				<name>20+0.25*d=43</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>67 331 115 361</position>
+				<barchart active="true" width="140" height="80" />
+			</node>
+			<node id="Ans1Strat1Step41">
+				<name>0.25*dt=23</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>66 444 114 474</position>
+				<barchart active="true" width="142" height="79" />
+			</node>
+			<node id="Ans1Strat1Step51">
+				<name>d=92</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>67 557 115 587</position>
+				<barchart active="true" width="139" height="79" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>439 39 487 69</position>
+				<barchart active="true" width="162" height="58" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>Try &lt;n&gt; != 92</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>800 163 848 193</position>
+				<barchart active="true" width="153" height="72" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>Try &lt;n&gt; == 92</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>803 310 851 340</position>
+				<barchart active="true" width="158" height="72" />
+			</node>
+			<node id="Ans1Strat1Step32">
+				<name>20+0.25*d&gt;43</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>433 333 481 363</position>
+				<barchart active="true" width="157" height="72" />
+			</node>
+			<node id="Ans1Strat1Step42">
+				<name>0.25*d&gt;23</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>436 430 484 460</position>
+				<barchart active="true" width="160" height="72" />
+			</node>
+			<node id="Ans1Strat1Step52">
+				<name>d&gt;92</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>436 531 484 561</position>
+				<barchart active="true" width="156" height="72" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>d: distance; c: cost</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>247 105 295 135</position>
+				<barchart active="true" width="141" height="79" />
+			</node>
+			<node id="Ans1Strat1Step6">
+				<name>Answer: &quot;&gt;=92&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>243 694 291 724</position>
+				<barchart active="true" width="158" height="72" />
+			</node>
+			<node id="R1211_T02">
+				<name>Choose variables</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>413 153 492 198</position>
+				<barchart active="true" width="141" height="65" />
+			</node>
+			<node id="R12_T02">
+				<name>Set up algebraic equations</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>53 189 127 252</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="R13_T02">
+				<name>Set up algebraic inequalities</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>586 414 675 476</position>
+				<barchart active="true" width="144" height="69" />
+			</node>
+			<node id="R11_T02">
+				<name>Set up numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>586 214 676 277</position>
+				<barchart active="true" width="136" height="72" />
+			</node>
+			<node id="R31_T02">
+				<name>Use numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>952 229 1056 271</position>
+				<barchart active="true" width="127" height="71" />
+			</node>
+			<node id="R323_T02">
+				<name>Simplify by addition and subtraction</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>212 472 312 530</position>
+				<barchart active="true" width="128" height="77" />
+			</node>
+			<node id="R324_T02">
+				<name>Simplify by multiplication and division</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>219 574 320 633</position>
+				<barchart active="true" width="141" height="73" />
+			</node>
+			<node id="R1213_T02">
+				<name>Set up linear model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>60 101 130 155</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="Ans1Strat2Step3">
+				<name>Answer: &quot;&gt;=92&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>804 423 852 453</position>
+				<barchart active="true" width="154" height="72" />
+			</node>
+			<node id="Ans1Strat1Step3Path">
+				<name>Solution Path</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>245 292 293 322</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/MagicTrick.xdsl view
@@ -0,0 +1,466 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic1" />
+			<state id="Algebraic2" />
+			<state id="Numeric1" />
+			<state id="Numeric2" />
+			<probabilities>0.28 0.27 0.15 0.3</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.495 0.495 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step3</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step4</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step5</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.495 0.495 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step3</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step4</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step5</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step7">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step6</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.495 0.495 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.595 0.395 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step3</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step4</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step5</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step7">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step6</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step6 Ans1Strat2Step7 Ans1Strat3Step2 Ans1Strat4Step7</parents>
+			<strengths>0 1 2 0 1 2 0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.06999999999999995 0.93</parameters>
+		</noisymax>
+		<noisyadder id="R121_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step1 Ans1Strat1Step2 Ans1Strat2Step2 Ans1Strat2Step3 Ans1Strat2Step4 Ans1Strat2Step5 Ans1Strat2Step6 Ans1Strat2Step7</parents>
+			<dstates>1 2 2 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1211_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans1Strat2Step1</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R3221_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step3 Ans1Strat2Step2 Ans1Strat2Step5 Ans1Strat1Step5</parents>
+			<dstates>1 2 2 2 2</dstates>
+			<weights>1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R3223_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step4 Ans1Strat1Step6 Ans1Strat2Step4 Ans1Strat2Step7</parents>
+			<dstates>1 2 2 2 2</dstates>
+			<weights>1 1 1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R31_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step3 Ans1Strat2Step6 Ans1Strat3Step2 Ans1Strat4Step1 Ans1Strat4Step2 Ans1Strat4Step3 Ans1Strat4Step4 Ans1Strat4Step5 Ans1Strat4Step6 Ans1Strat4Step7</parents>
+			<dstates>1 2 2 2 2 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 1 1 1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R11_T05">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat3Step1 Ans1Strat4Step1 Ans1Strat4Step2 Ans1Strat4Step3 Ans1Strat4Step4 Ans1Strat4Step5 Ans1Strat4Step6 Ans1Strat4Step7</parents>
+			<dstates>1 2 2 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>488 757 570 808</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>((x+8)*3-4+x)/4+2-x</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>57 193 105 223</position>
+				<barchart active="true" width="120" height="72" />
+			</node>
+			<node id="Ans1Strat1Step3">
+				<name>(3x+24-4+x)/4+2-x</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>58 306 106 336</position>
+				<barchart active="true" width="122" height="72" />
+			</node>
+			<node id="Ans1Strat1Step4">
+				<name>(4x+20)/4+2-x</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>57 426 105 456</position>
+				<barchart active="true" width="121" height="72" />
+			</node>
+			<node id="Ans1Strat1Step5">
+				<name>x+5+2-x</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>59 545 107 575</position>
+				<barchart active="true" width="121" height="72" />
+			</node>
+			<node id="Ans1Strat1Step6">
+				<name>Answer: &quot;7&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>62 664 110 694</position>
+				<barchart active="true" width="120" height="72" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>506 38 554 68</position>
+				<barchart active="true" width="140" height="90" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>x+8</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>356 99 404 129</position>
+				<barchart active="true" width="110" height="72" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>(x+8)*3=3x+24</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>354 198 402 228</position>
+				<barchart active="true" width="107" height="72" />
+			</node>
+			<node id="Ans1Strat2Step3">
+				<name>3x+24-4=3x+20</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>358 293 406 323</position>
+				<barchart active="true" width="104" height="72" />
+			</node>
+			<node id="Ans1Strat2Step4">
+				<name>3x+20+x=4x+20</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>356 389 404 419</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans1Strat2Step5">
+				<name>(4x+20)/4=x+5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>359 483 407 513</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans1Strat3Step1">
+				<name>((&lt;n&gt;+8)*3-4+&lt;n&gt;)/4+2-&lt;n&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>504 145 552 175</position>
+				<barchart active="true" width="162" height="72" />
+			</node>
+			<node id="Ans1Strat3Step2">
+				<name>answer: &quot;7&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>501 629 549 659</position>
+				<barchart active="true" width="89" height="72" />
+			</node>
+			<node id="Ans1Strat4Step1">
+				<name>&lt;n&gt;+8=&lt;a1&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>718 100 766 130</position>
+				<barchart active="true" width="89" height="72" />
+			</node>
+			<node id="Ans1Strat4Step2">
+				<name>&lt;a1&gt;*3=&lt;a2&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>721 204 769 234</position>
+				<barchart active="true" width="90" height="72" />
+			</node>
+			<node id="Ans1Strat4Step3">
+				<name>&lt;a2&gt;-4=&lt;a3&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>721 305 769 335</position>
+				<barchart active="true" width="92" height="72" />
+			</node>
+			<node id="Ans1Strat4Step4">
+				<name>&lt;a3&gt;+&lt;n&gt;=&lt;a4&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>722 406 770 436</position>
+				<barchart active="true" width="107" height="72" />
+			</node>
+			<node id="Ans1Strat4Step5">
+				<name>&lt;a4&gt;/4=&lt;a5&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>720 497 768 527</position>
+				<barchart active="true" width="91" height="72" />
+			</node>
+			<node id="Ans1Strat2Step6">
+				<name>x+5+2=x+7</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>356 578 404 608</position>
+				<barchart active="true" width="103" height="72" />
+			</node>
+			<node id="Ans1Strat2Step7">
+				<name>Answer: &quot;x+7-x=7&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>358 680 406 710</position>
+				<barchart active="true" width="118" height="72" />
+			</node>
+			<node id="Ans1Strat4Step6">
+				<name>&lt;a5&gt;+2=&lt;a6&gt;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>722 592 770 622</position>
+				<barchart active="true" width="89" height="72" />
+			</node>
+			<node id="Ans1Strat4Step7">
+				<name>Answer: &quot;&lt;a6&gt;-&lt;n&gt;=7&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>724 696 772 726</position>
+				<barchart active="true" width="139" height="72" />
+			</node>
+			<node id="R1211_T05">
+				<name>Choose variables</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>205 167 284 212</position>
+				<barchart active="true" width="128" height="55" />
+			</node>
+			<node id="R11_T05">
+				<name>Set up numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>559 277 649 340</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R31_T05">
+				<name>Use numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>554 453 658 495</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R3221_T05">
+				<name>Expand expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>199 399 293 442</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="R121_T05">
+				<name>Set up algebraic expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>183 278 307 318</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="R3223_T05">
+				<name>Combine like terms</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>194 513 293 554</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>x - variable</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>58 83 106 113</position>
+				<barchart active="true" width="120" height="72" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/MakingASquare.xdsl view
@@ -0,0 +1,237 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic1" />
+			<state id="Algebraic2" />
+			<probabilities>0.37 0.63</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.495 0.495 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step3</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step4</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step5</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.495 0.495 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step2</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step6 Ans1Strat2Step3</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R3221_T04">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step5</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1212_T04">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step2 Ans1Strat2Step1 Ans1Strat1Step4 Ans1Strat1Step3 Ans1Strat1Step2 Ans1Strat1Step1</parents>
+			<dstates>1 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.8 0.2 0.4 0.6 0 1 0.8 0.2 0.4 0.6 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1214_T04">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans1Strat1Step3 Ans1Strat2Step2</parents>
+			<dstates>1 2 2 2</dstates>
+			<weights>1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R3223_T04">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step6</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>357 622 439 673</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>area of a triangle: a*b/2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>136 83 184 113</position>
+				<barchart active="true" width="146" height="54" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>side of a small square: b-a</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>132 178 180 208</position>
+				<barchart active="true" width="173" height="54" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>329 19 377 49</position>
+				<barchart active="true" width="114" height="54" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>hypotenuse: sqrt(a^2+b^2)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>503 172 551 202</position>
+				<barchart active="true" width="180" height="54" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>area of a large square: hypotenuse^2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>500 321 548 351</position>
+				<barchart active="true" width="211" height="54" />
+			</node>
+			<node id="Ans1Strat1Step3">
+				<name>area of a small square: (b-a)^2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>134 273 182 303</position>
+				<barchart active="true" width="175" height="54" />
+			</node>
+			<node id="Ans1Strat1Step4">
+				<name>area of a large square: 4*a*b/2+(b-a)^2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>138 368 186 398</position>
+				<barchart active="true" width="227" height="54" />
+			</node>
+			<node id="Ans1Strat1Step5">
+				<name>2ab+b^2 - 2ab +a^2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>141 457 189 487</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="Ans1Strat1Step6">
+				<name>Answer:&quot; b^2 + a^2&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>139 549 187 579</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="Ans1Strat2Step3">
+				<name>Answer: &quot;b^2 + a^2&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>505 447 553 477</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="R3221_T04">
+				<name>Expand expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>311 396 405 439</position>
+				<barchart active="true" width="128" height="57" />
+			</node>
+			<node id="R1212_T04">
+				<name>Set up geometric model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>310 102 394 158</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R1214_T04">
+				<name>Set up quadratic model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>313 233 393 290</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="R3223_T04">
+				<name>Combine like terms</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>309 515 408 556</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/Matryoshka.xdsl view
@@ -0,0 +1,509 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic" />
+			<state id="Numerical1" />
+			<state id="Numerical2" />
+			<probabilities>0.32 0.28 0.4</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.595 0.395 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step3</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step4</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.495 0.495 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step2</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step3</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step4</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step5</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.595 0.395 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step1</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step3</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step4</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step5</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step7">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step6</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step8">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step7</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step9">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step8</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step10">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step9</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step11">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step10</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step5 Ans1Strat2Step6 Ans1Strat3Step11</parents>
+			<strengths>0 1 2 0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R1211_T10">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R11_T10_P1">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step1 Ans1Strat2Step2 Ans1Strat2Step3 Ans1Strat2Step4 Ans1Strat2Step5</parents>
+			<dstates>1 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R11_T10_P2">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat3Step1 Ans1Strat3Step2 Ans1Strat3Step3 Ans1Strat3Step4 Ans1Strat3Step5 Ans1Strat3Step6 Ans1Strat3Step7 Ans1Strat3Step8 Ans1Strat3Step9 Ans1Strat3Step10</parents>
+			<dstates>1 2 2 2 2 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 1 1 1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="R11_T10">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R11_T10_P1 R11_T10_P2</parents>
+			<probabilities>1 0 0.5 0.5 0.5 0.5 0 1</probabilities>
+		</cpt>
+		<noisyadder id="R31_T10_P1">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step5 Ans1Strat2Step4 Ans1Strat2Step3 Ans1Strat2Step2 Ans1Strat2Step1</parents>
+			<dstates>1 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R31_T10_P2">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat3Step10 Ans1Strat3Step9 Ans1Strat3Step8 Ans1Strat3Step7 Ans1Strat3Step6 Ans1Strat3Step5 Ans1Strat3Step4 Ans1Strat3Step2 Ans1Strat3Step1 Ans1Strat3Step3</parents>
+			<dstates>1 2 2 2 2 2 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 1 1 1 1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="R31_T10">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R31_T10_P1 R31_T10_P2</parents>
+			<probabilities>1 0 0.5 0.5 0.5 0.5 0 1</probabilities>
+		</cpt>
+		<noisyadder id="R1215_T10">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R321_T10">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step3 Ans1Strat1Step4</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>388 895 470 946</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>h: height; n: number</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>290 148 338 178</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>h(n)=32*0,75^(n-1)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>288 316 336 346</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step3">
+				<name>Try &lt;n&gt; != 6</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>288 483 336 513</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step4">
+				<name>Try &lt;n&gt; == 6</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>289 658 337 688</position>
+				<barchart active="true" width="103" height="72" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>510 60 558 90</position>
+				<barchart active="true" width="140" height="72" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>2nd: 32*0.75=24</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>476 195 524 225</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>3d: 24*0.75=18</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>473 292 521 322</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat2Step3">
+				<name>4th: 18*0.75=13.5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>476 400 524 430</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat2Step4">
+				<name>5th: 13.5*0.75=10.125</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>478 509 526 539</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat2Step5">
+				<name>6th: 10.125*0.75=7.594</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>479 624 527 654</position>
+				<barchart active="true" width="144" height="72" />
+			</node>
+			<node id="Ans1Strat3Step1">
+				<name>32*25/100=8</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>667 116 715 146</position>
+				<barchart active="true" width="111" height="72" />
+			</node>
+			<node id="Ans1Strat3Step2">
+				<name>2nd: 32-8=24</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>821 154 869 184</position>
+				<barchart active="true" width="107" height="72" />
+			</node>
+			<node id="Ans1Strat3Step3">
+				<name>24*25/100=6</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>962 202 1010 232</position>
+				<barchart active="true" width="105" height="72" />
+			</node>
+			<node id="Ans1Strat3Step4">
+				<name>3d: 24-6=18</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>1002 301 1050 331</position>
+				<barchart active="true" width="103" height="72" />
+			</node>
+			<node id="Ans1Strat3Step5">
+				<name>18*25/100=4.5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>1043 400 1091 430</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans1Strat3Step6">
+				<name>4th: 18-4.5=13.5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>1040 499 1088 529</position>
+				<barchart active="true" width="106" height="72" />
+			</node>
+			<node id="Ans1Strat3Step7">
+				<name>13.5*25/100=3.375</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>1020 607 1068 637</position>
+				<barchart active="true" width="152" height="72" />
+			</node>
+			<node id="Ans1Strat1Step5">
+				<name>Answer: &quot;5&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>292 757 340 787</position>
+				<barchart active="true" width="110" height="72" />
+			</node>
+			<node id="Ans1Strat2Step6">
+				<name>Answer: &quot;5&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>479 734 527 764</position>
+				<barchart active="true" width="112" height="72" />
+			</node>
+			<node id="Ans1Strat3Step8">
+				<name>5th: 13.5-3.375=10.125</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>976 705 1024 735</position>
+				<barchart active="true" width="152" height="72" />
+			</node>
+			<node id="Ans1Strat3Step9">
+				<name>10.125*25/100=2.531</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>896 802 944 832</position>
+				<barchart active="true" width="152" height="72" />
+			</node>
+			<node id="Ans1Strat3Step10">
+				<name>6th: 10.125-2.531=7.594</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>712 875 760 905</position>
+				<barchart active="true" width="152" height="72" />
+			</node>
+			<node id="Ans1Strat3Step11">
+				<name>Answer: &quot;5&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>555 923 603 953</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="R1211_T10">
+				<name>Choose variables</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>194 227 273 272</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="R11_T10">
+				<name>Set up numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>649 388 739 451</position>
+				<barchart active="true" width="128" height="75" />
+			</node>
+			<node id="R31_T10">
+				<name>Use numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>629 690 733 732</position>
+				<barchart active="true" width="128" height="73" />
+			</node>
+			<node id="R321_T10">
+				<name>Substitute</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>208 567 275 605</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="R1215_T10">
+				<name>Set up exponential model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>187 384 276 444</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R11_T10_P1">
+				<name>Set up numeric expressions (part 1)</name>
+				<interior color="ffffe4" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>631 258 680 288</position>
+				<barchart active="true" width="128" height="80" />
+			</node>
+			<node id="R11_T10_P2">
+				<name>Set up numeric expressions (part 2)</name>
+				<interior color="ffffe4" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>816 296 865 326</position>
+				<barchart active="true" width="128" height="80" />
+			</node>
+			<node id="R31_T10_P1">
+				<name>Use numeric expressions (part 1)</name>
+				<interior color="ffffe4" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>656 553 705 583</position>
+				<barchart active="true" width="128" height="80" />
+			</node>
+			<node id="R31_T10_P2">
+				<name>Use numeric expressions (part 2)</name>
+				<interior color="ffffe4" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>822 558 871 588</position>
+				<barchart active="true" width="128" height="80" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/Pattern.xdsl view
@@ -0,0 +1,449 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic" />
+			<state id="Numeric1" />
+			<state id="Numeric2" />
+			<probabilities>0.8 0.15 0.04999999999999996</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step1Path">
+			<state id="Variables" />
+			<state id="No_variables" />
+			<probabilities>0.5 0.5</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step11">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat Ans1Strat1Step1Path</parents>
+			<probabilities>0.595 0.395 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step12">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat Ans1Strat1Step1Path</parents>
+			<probabilities>0.005 0.005 0.99 0.395 0.595 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step11 Ans1Strat1Step12</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.6 0.39 0.01 0.1899999999999999 0.8 0.01 0 0 1 0.6 0.39 0.01 0.1899999999999999 0.8 0.01 0 0 1 0.0004999999999999449 0.0004999999999999449 0.999</parameters>
+		</noisymax>
+		<cpt id="Ans1Strat1Step3Path">
+			<state id="Equation" />
+			<state id="Inequality" />
+			<probabilities>0.8 0.2</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step31">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2 Ans1Strat1Step3Path</parents>
+			<probabilities>0.6 0.39 0.01 0.005 0.005 0.99 0.19 0.8 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step41">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step31</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step51">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step41</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step32">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step2 Ans1Strat1Step3Path</parents>
+			<probabilities>0.005 0.005 0.99 0.6 0.39 0.01 0.005 0.005 0.99 0.19 0.8 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step42">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step32</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step52">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step42</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1Strat1Step6">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step51 Ans1Strat1Step52</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.0004999999999999449 0.0004999999999999449 0.999</parameters>
+		</noisymax>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.595 0.395 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.495 0.495 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step2</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step3</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step5">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step4</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step6 Ans1Strat2Step3 Ans1Strat3Step5</parents>
+			<strengths>0 1 2 0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R1213_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step2</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1211_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step11</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R12_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step31</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R323_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step41 Ans1Strat1Step42</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1.5 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R324_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step51 Ans1Strat1Step52</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1.5 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R31_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat2Step1 Ans1Strat2Step2 Ans1Strat3Step2 Ans1Strat3Step3 Ans1Strat3Step4</parents>
+			<dstates>1 2 2 2 2 2</dstates>
+			<weights>1 1 1 1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R13_T03">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step32</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>567 714 649 765</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat3Step1">
+				<name>Start: 7; Step: 3</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>845 101 893 131</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat3Step2">
+				<name>50-7=43</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>848 235 896 265</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat3Step3">
+				<name>43/3=14.3</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>851 371 899 401</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>607 30 655 60</position>
+				<barchart active="true" width="140" height="72" />
+			</node>
+			<node id="Ans1Strat1Step11">
+				<name>n: pattern; G: tiles</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>253 58 301 88</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step12">
+				<name>Start: 4; Step: 3</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>427 178 475 208</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>G = 4 + 3n</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>261 197 309 227</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step31">
+				<name>4+3n = 50</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>97 295 145 325</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step41">
+				<name>3n = 46</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>99 382 147 412</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>try &lt;n&gt; &lt; 16 (7,10,...)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>645 124 693 154</position>
+				<barchart active="true" width="136" height="72" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>try &lt;n&gt; == 16 (52)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>645 375 693 405</position>
+				<barchart active="true" width="154" height="72" />
+			</node>
+			<node id="Ans1Strat2Step3">
+				<name>Answer: &quot;16&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>644 615 692 645</position>
+				<barchart active="true" width="150" height="72" />
+			</node>
+			<node id="Ans1Strat3Step4">
+				<name>14.3+1=15.3</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>853 496 901 526</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step51">
+				<name>n = 15.33</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>102 474 150 504</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step32">
+				<name>4+3n &gt; 50</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>427 290 475 320</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step42">
+				<name>3n &gt; 46</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>428 382 476 412</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step52">
+				<name>n &gt; 15.33</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>428 473 476 503</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat3Step5">
+				<name>Answer: &quot;16&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>851 640 899 670</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat1Step6">
+				<name>Answer: &quot;16&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>272 642 320 672</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="R1211_T03">
+				<name>Choose variables</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>91 103 170 148</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="R12_T03">
+				<name>Set up algebraic equations</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>245 342 319 405</position>
+				<barchart active="true" width="143" height="68" />
+			</node>
+			<node id="R13_T03">
+				<name>Set up algebraic inequalities</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>552 206 641 268</position>
+				<barchart active="true" width="128" height="71" />
+			</node>
+			<node id="R31_T03">
+				<name>Use numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>680 257 784 299</position>
+				<barchart active="true" width="113" height="74" />
+			</node>
+			<node id="R323_T03">
+				<name>Simplify by addition and subtraction</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>231 420 329 485</position>
+				<barchart active="true" width="141" height="71" />
+			</node>
+			<node id="R324_T03">
+				<name>Simplify by multiplication and division</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>231 509 334 580</position>
+				<barchart active="true" width="144" height="80" />
+			</node>
+			<node id="R1213_T03">
+				<name>Set up linear model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>96 169 166 223</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="Ans1Strat1Step3Path">
+				<name>Solution Path</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>260 271 308 301</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="Ans1Strat1Step1Path">
+				<name>Solution Path</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>429 89 477 119</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/RectangleArea.xdsl view
@@ -0,0 +1,218 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<probabilities>0.395 0.01 0.595</probabilities>
+		</cpt>
+		<cpt id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.05 0.95 0.5 0.5 0.95 0.05</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step11">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<probabilities>0.29 0.01 0.7</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step12">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<probabilities>0.29 0.01 0.7</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step13">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<probabilities>0.29 0.01 0.7</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step14">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<probabilities>0.29 0.01 0.7</probabilities>
+		</cpt>
+		<noisyadder id="R1212_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans2Strat1Step11 Ans2Strat1Step12 Ans2Strat1Step13 Ans2Strat1Step14</parents>
+			<dstates>1 1 1 1 1 1</dstates>
+			<weights>2 1 0.5 1 0.5 0.1</weights>
+			<parameters>0.3 0.7 0 1 0.7 0.3 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R1214_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step1 Ans2Strat1Step11 Ans2Strat1Step12 Ans2Strat1Step13 Ans2Strat1Step14</parents>
+			<dstates>1 1 1 1 1 1</dstates>
+			<weights>2 1 0.5 1 0.5 0.1</weights>
+			<parameters>0.3 0.7 0 1 0.7 0.3 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.5 0.5</parameters>
+		</noisyadder>
+		<noisymax id="Ans2Strat1Step2">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<parents>Ans2Strat1Step11 Ans2Strat1Step12 Ans2Strat1Step13 Ans2Strat1Step14</parents>
+			<strengths>0 1 2 0 1 2 0 1 2 0 1 2</strengths>
+			<parameters>0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4000000000000001 0.3 0 0 1 0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4000000000000001 0.3 0 0 1 0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4000000000000001 0.3 0 0 1 0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4000000000000001 0.3 0 0 1 9.00000000000345e-05 9.99999999995449e-06 0.9999</parameters>
+		</noisymax>
+		<noisymax id="Ans3Strat1Step1">
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<state id="Correct" />
+			<parents>Ans2Strat1Step2 Ans1Strat1Step1</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4 0.3 0 0 1 0.6499999999999999 0.01000000000000001 0.34 0.2999999999999998 0.4 0.3 0 0 1 0.0009000000000000119 9.999999999998899e-05 0.999</parameters>
+		</noisymax>
+		<noisyadder id="R3221_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat1Step1</parents>
+			<dstates>1 1</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.3 0.7 0 1 0.7 0.3 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans2Strat1Step2</parents>
+			<probabilities>0.05 0.95 0.5 0.5 0.95 0.05</probabilities>
+		</cpt>
+		<noisyadder id="R12_T02">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans3Strat1Step1</parents>
+			<dstates>1 1</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.3 0.7 0 1 0.7 0.3 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans3Strat1Step1</parents>
+			<probabilities>0.05 0.95 0.5 0.5 0.95 0.05</probabilities>
+		</cpt>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Q1 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>24 119 106 170</position>
+				<barchart active="true" width="97" height="54" />
+			</node>
+			<node id="Ans2Strat1Step11">
+				<name>a^2</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>296 82 344 112</position>
+				<barchart active="true" width="97" height="72" />
+			</node>
+			<node id="Ans2Strat1Step12">
+				<name>5a</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>406 81 454 111</position>
+				<barchart active="true" width="98" height="72" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>Answer: &quot;(a+5)(a+b)&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>145 45 193 75</position>
+				<barchart active="true" width="144" height="72" />
+			</node>
+			<node id="Ans2Strat1Step13">
+				<name>ab</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>524 81 572 111</position>
+				<barchart active="true" width="96" height="72" />
+			</node>
+			<node id="Ans3Strat1Step1">
+				<name>Answer: &quot;(a+5)(a+b)=a^2+5a+ab+5b&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>365 282 413 312</position>
+				<barchart active="true" width="208" height="72" />
+			</node>
+			<node id="Ans2Strat1Step14">
+				<name>5b</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>650 81 698 111</position>
+				<barchart active="true" width="110" height="72" />
+			</node>
+			<node id="R1212_T02">
+				<name>Set up geometric model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>145 183 229 239</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R1214_T02">
+				<name>Set up quadratic model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>384 161 464 218</position>
+				<barchart active="true" width="128" height="70" />
+			</node>
+			<node id="R3221_T02">
+				<name>Expand expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>541 361 635 404</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="R12_T02">
+				<name>Set up algebraic equations</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>124 305 252 345</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="Ans2">
+				<name>Q2 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>689 280 771 331</position>
+				<barchart active="true" width="91" height="54" />
+			</node>
+			<node id="Ans3">
+				<name>Q3 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>344 364 426 415</position>
+				<barchart active="true" width="130" height="54" />
+			</node>
+			<node id="Ans2Strat1Step2">
+				<name>Answer: &quot;a^2+5a+ab+5b&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>593 209 641 239</position>
+				<barchart active="true" width="150" height="72" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/StudentModel.xdsl view
@@ -0,0 +1,283 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network2" numsamples="1000" discsamples="10000">
+	<nodes>
+		<cpt id="R">
+			<state id="Yes" />
+			<state id="No" />
+			<probabilities>0.5 0.5</probabilities>
+		</cpt>
+		<cpt id="R1">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R13">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R1</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R12">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R1</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R121">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R12</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R1211">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R121</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R11">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R1</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R3">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R31">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R3</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R32">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R3</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R322">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R32</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R3222">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R322</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R1212">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R121</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R1213">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R121</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R3221">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R322</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R323">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R32</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R324">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R32</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R1214">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R121</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R1215">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R121</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R321">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R32</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+		<cpt id="R3223">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>R322</parents>
+			<probabilities>0.6 0.4 0.4 0.6</probabilities>
+		</cpt>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.1.1104.0 ACADEMIC" name="Network2" faultnameformat="nodestate">
+			<node id="R1">
+				<name>Set up expressions, equations and inequalities</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>77 54 300 92</position>
+			</node>
+			<node id="R1211">
+				<name>Choose variables</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>51 216 130 261</position>
+			</node>
+			<node id="R12">
+				<name>Set up algebraic equations</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>168 113 242 176</position>
+			</node>
+			<node id="R13">
+				<name>Set up algebraic inequalities</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>249 118 338 180</position>
+			</node>
+			<node id="R11">
+				<name>Set up numerical expressions</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>58 118 148 181</position>
+			</node>
+			<node id="R3">
+				<name>Simplify algebraic expressions and solve equations</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>405 57 640 98</position>
+			</node>
+			<node id="R31">
+				<name>Use numerical expressions</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>408 120 512 162</position>
+			</node>
+			<node id="R32">
+				<name>Solve equations</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>529 122 608 163</position>
+			</node>
+			<node id="R">
+				<name>Relations</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>329 6 414 35</position>
+			</node>
+			<node id="R322">
+				<name>Simplify expressions</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>459 191 558 232</position>
+			</node>
+			<node id="R3221">
+				<name>Expand expressions</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>400 265 494 308</position>
+			</node>
+			<node id="R323">
+				<name>Simplify by addition and subtraction</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>567 184 669 243</position>
+			</node>
+			<node id="R324">
+				<name>Simplify by multiplication and division</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>675 184 776 243</position>
+			</node>
+			<node id="R321">
+				<name>Substitute</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>377 196 444 234</position>
+			</node>
+			<node id="R121">
+				<name>Set up algebraic expressions</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>157 192 285 232</position>
+				<barchart width="128" height="64" />
+			</node>
+			<node id="R1212">
+				<name>Set up geometric model</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>64 261 148 317</position>
+			</node>
+			<node id="R1213">
+				<name>Set up linear model</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>152 265 222 319</position>
+			</node>
+			<node id="R1214">
+				<name>Set up quadratic model</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>224 260 304 317</position>
+			</node>
+			<node id="R1215">
+				<name>Set up exponential model</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>298 233 387 293</position>
+			</node>
+			<node id="R3222">
+				<name>Divide out common factors</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>496 262 610 310</position>
+			</node>
+			<node id="R3223">
+				<name>Combine like terms</name>
+				<interior color="e5f6f7" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>618 268 717 309</position>
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/TheatreRate.xdsl view
@@ -0,0 +1,390 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans2Strat">
+			<state id="Algebraic" />
+			<state id="Numeric" />
+			<probabilities>0.71 0.29</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat</parents>
+			<probabilities>0.595 0.395 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R1211_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step1</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2Strat1Step4Path">
+			<state id="Equation" />
+			<state id="Inequality" />
+			<probabilities>0.71 0.29</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step21">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step22">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R1213_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step21 Ans2Strat1Step22</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.495 0.495 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat2Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R121_T06">
+			<state id="State0" />
+			<state id="State1" />
+			<parents>Ans2Strat2Step1 Ans2Strat2Step2</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R31_T06">
+			<state id="State0" />
+			<state id="State1" />
+			<parents>Ans2Strat2Step1 Ans2Strat2Step2</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2Strat1Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step21 Ans2Strat1Step22</parents>
+			<probabilities>0.9 0.095 0.005 0.095 0.9 0.005 0.005 0.005 0.99 0.095 0.9 0.005 0.045 0.95 0.005 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step42">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step3 Ans2Strat1Step4Path</parents>
+			<probabilities>0.005 0.005 0.99 0.6 0.39 0.01 0.005 0.005 0.99 0.19 0.8 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R13_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step42</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2Strat1Step41">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step3 Ans2Strat1Step4Path</parents>
+			<probabilities>0.7 0.29 0.01 0.005 0.005 0.99 0.29 0.7 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step51">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step41</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step52">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step42</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R323_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step51 Ans2Strat1Step52</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.8 0.2 0.4 0.6 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<cpt id="Ans2Strat1Step61">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step51</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans2Strat1Step62">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step52</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisyadder id="R324_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step61 Ans2Strat1Step62</parents>
+			<dstates>1 2 2</dstates>
+			<weights>1 1 0.1</weights>
+			<parameters>0.6 0.4 0.2 0.8 0 1 0.6 0.4 0.2 0.8 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisymax id="Ans2Strat1Step7">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat1Step61 Ans2Strat1Step62</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.8 0.19 0.01 0.39 0.6 0.01 0 0 1 0.0004999999999999449 0.0004999999999999449 0.999</parameters>
+		</noisymax>
+		<cpt id="Ans2Strat2Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans2Strat2Step2</parents>
+			<probabilities>0.8 0.19 0.01 0.39 0.6 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans2Strat2Step3 Ans2Strat1Step7</parents>
+			<strengths>0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.09999999999999998 0.9</parameters>
+		</noisymax>
+		<noisyadder id="R12_T06">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans2Strat1Step41</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans2Strat1Step21">
+				<name>R1: p=30+4s</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>47 209 95 239</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans2Strat2Step1">
+				<name>Try &lt;n&gt; != 8</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>536 102 584 132</position>
+				<barchart active="true" width="108" height="72" />
+			</node>
+			<node id="Ans2Strat1Step22">
+				<name>R2: p=8s</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>342 206 390 236</position>
+				<barchart active="true" width="103" height="72" />
+			</node>
+			<node id="Ans2Strat1Step42">
+				<name>30+4s &lt; 8s</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>345 371 393 401</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="Ans2Strat1Step52">
+				<name>4s &gt; 30</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>348 479 396 509</position>
+				<barchart active="true" width="100" height="72" />
+			</node>
+			<node id="Ans2Strat1Step62">
+				<name>s &gt; 7,5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>342 596 390 626</position>
+				<barchart active="true" width="103" height="72" />
+			</node>
+			<node id="Ans2Strat2Step2">
+				<name>Try &lt;n&gt; == 8</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>541 390 589 420</position>
+				<barchart active="true" width="108" height="72" />
+			</node>
+			<node id="Ans2Strat2Step3">
+				<name>Answer: &quot;8&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>538 699 586 729</position>
+				<barchart active="true" width="109" height="72" />
+			</node>
+			<node id="Ans2">
+				<name>Q2 Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>343 758 425 809</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans2Strat1Step1">
+				<name>n - number of shows; p - price</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>188 102 236 132</position>
+				<barchart active="true" width="182" height="72" />
+			</node>
+			<node id="R1211_T06">
+				<name>Choose variables</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>372 132 451 177</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="R1213_T06">
+				<name>Set up linear model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>190 197 260 251</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="Ans2Strat1Step41">
+				<name>30+4s = 8s</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>50 365 98 395</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans2Strat1Step7">
+				<name>Answer: &quot;8&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>197 705 245 735</position>
+				<barchart active="true" width="115" height="72" />
+			</node>
+			<node id="Ans2Strat1Step51">
+				<name>4s = 30</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>48 472 96 502</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans2Strat1Step61">
+				<name>s=7,5</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>46 579 94 609</position>
+				<barchart active="true" width="100" height="72" />
+			</node>
+			<node id="R12_T06">
+				<name>Set up algebraic equations</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>187 430 261 493</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R13_T06">
+				<name>Set up algebraic inequalities</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>451 452 540 514</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="R323_T06">
+				<name>Simplify by addition and subtraction</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>181 509 266 578</position>
+				<barchart active="true" width="128" height="69" />
+			</node>
+			<node id="R324_T06">
+				<name>Simplify by multiplication and division</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>182 587 266 658</position>
+				<barchart active="true" width="140" height="73" />
+			</node>
+			<node id="Ans2Strat">
+				<name>Q2 Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>360 14 442 65</position>
+				<barchart active="true" width="132" height="54" />
+			</node>
+			<node id="R31_T06">
+				<name>Use numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>580 208 681 271</position>
+				<barchart active="true" width="128" height="70" />
+			</node>
+			<node id="R121_T06">
+				<name>Set up numerical expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>443 206 544 269</position>
+				<barchart active="true" width="128" height="68" />
+			</node>
+			<node id="Ans2Strat1Step4Path">
+				<name>Solution Path</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>202 365 250 395</position>
+				<barchart active="true" width="128" height="54" />
+			</node>
+			<node id="Ans2Strat1Step3">
+				<name>p=30+4s ? 8s</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>201 287 249 317</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/VPattern.xdsl view
@@ -0,0 +1,237 @@+<?xml version="1.0" encoding="ISO-8859-1"?>
+<!-- This network was created in GeNIe Academic, which can be used for educational and research purposes only -->
+<smile version="1.0" id="Network1" numsamples="10000" discsamples="10000">
+	<nodes>
+		<cpt id="Ans1Strat">
+			<state id="Algebraic1" />
+			<state id="Algebraic2" />
+			<state id="Algebraic3" />
+			<state id="Algebraic4" />
+			<probabilities>0.37 0.37 0.12 0.14</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.495 0.495 0.01 0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat1Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat1Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.495 0.495 0.01 0.005 0.005 0.99 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat2Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat2Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.595 0.395 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step2</parents>
+			<probabilities>0.6 0.39 0.01 0.19 0.8 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat3Step4">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat3Step3</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat</parents>
+			<probabilities>0.005 0.005 0.99 0.005 0.005 0.99 0.005 0.005 0.99 0.495 0.495 0.01</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step2">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step1</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<cpt id="Ans1Strat4Step3">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<state id="Not_taken" />
+			<parents>Ans1Strat4Step2</parents>
+			<probabilities>0.7 0.29 0.01 0.29 0.7 0.01 0.005 0.005 0.99</probabilities>
+		</cpt>
+		<noisymax id="Ans1">
+			<state id="Correct" />
+			<state id="Incorrect" />
+			<parents>Ans1Strat1Step2 Ans1Strat2Step2 Ans1Strat3Step4 Ans1Strat4Step3</parents>
+			<strengths>0 1 2 0 1 2 0 1 2 0 1 2</strengths>
+			<parameters>0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.8 0.2 0.09999999999999998 0.9 0 1 0.06999999999999995 0.93</parameters>
+		</noisymax>
+		<noisyadder id="R1213_T07">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat1Step2 Ans1Strat2Step2 Ans1Strat3Step3 Ans1Strat4Step3</parents>
+			<dstates>1 2 2 2 2</dstates>
+			<weights>1 1 1 1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.7 0.3 0.3 0.7 0 1 0.8 0.2 0.4 0.6 0 1 0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+		<noisyadder id="R3221_T08">
+			<state id="Yes" />
+			<state id="No" />
+			<parents>Ans1Strat3Step4</parents>
+			<dstates>1 2</dstates>
+			<weights>1 0.1</weights>
+			<parameters>0.7 0.3 0.3 0.7 0 1 0.5 0.5</parameters>
+		</noisyadder>
+	</nodes>
+	<extensions>
+		<genie version="1.0" app="GeNIe 2.3.3828.0 ACADEMIC" name="Network1" faultnameformat="nodestate">
+			<node id="Ans1">
+				<name>Final Answer</name>
+				<interior color="ccffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>291 569 373 620</position>
+				<barchart active="true" width="116" height="54" />
+			</node>
+			<node id="Ans1Strat1Step1">
+				<name>center:1 + side:R + side:R</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>79 286 127 316</position>
+				<barchart active="true" width="146" height="72" />
+			</node>
+			<node id="Ans1Strat1Step2">
+				<name>Answer: &quot;N=1+2R&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>76 405 124 435</position>
+				<barchart active="true" width="128" height="72" />
+			</node>
+			<node id="Ans1Strat">
+				<name>Solution Strategy</name>
+				<interior color="ccffcc" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>311 65 359 95</position>
+				<barchart active="true" width="140" height="90" />
+			</node>
+			<node id="Ans1Strat2Step1">
+				<name>side1: R + side2: R+1</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>235 289 283 319</position>
+				<barchart active="true" width="127" height="72" />
+			</node>
+			<node id="Ans1Strat2Step2">
+				<name>Answer: &quot;N=1+2R&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>234 396 282 426</position>
+				<barchart active="true" width="120" height="72" />
+			</node>
+			<node id="Ans1Strat3Step1">
+				<name>step1: 3 dots</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>371 162 419 192</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans1Strat3Step2">
+				<name>stepR: 2*(R-1) dots</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>373 262 421 292</position>
+				<barchart active="true" width="129" height="72" />
+			</node>
+			<node id="Ans1Strat3Step3">
+				<name>N=3+2(R-1)</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>369 360 417 390</position>
+				<barchart active="true" width="101" height="72" />
+			</node>
+			<node id="Ans1Strat3Step4">
+				<name>Answer: &quot;N=1+2R&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>369 460 417 490</position>
+				<barchart active="true" width="115" height="72" />
+			</node>
+			<node id="R1213_T07">
+				<name>Set up linear model</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>108 518 182 581</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="R3221_T08">
+				<name>Expand expressions</name>
+				<interior color="ffff99" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>490 530 584 573</position>
+				<barchart active="true" width="128" height="64" />
+			</node>
+			<node id="Ans1Strat4Step1">
+				<name>step0: 1 dot</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>516 162 564 192</position>
+				<barchart active="true" width="102" height="72" />
+			</node>
+			<node id="Ans1Strat4Step3">
+				<name>Answer: &quot;N=1+2R&quot;</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>520 441 568 471</position>
+				<barchart active="true" width="118" height="72" />
+			</node>
+			<node id="Ans1Strat4Step2">
+				<name>step: +2 dots</name>
+				<interior color="ffffff" />
+				<outline color="000080" />
+				<font color="000000" name="Arial" size="8" />
+				<position>517 291 565 321</position>
+				<barchart active="true" width="129" height="72" />
+			</node>
+		</genie>
+	</extensions>
+</smile>
+ networks/labels.xml view
@@ -0,0 +1,655 @@+<?xml version="1.0" encoding="utf-8"?>+<nodes>+    <node id="R1">+        <title>+            <lang id="en">Set up expressions, equations and inequalities</lang>+            <lang id="fr">Produire des expressions, des équations et des inégalités</lang>+            <lang id="nl">Uitdrukkingen, vergelijkheden en ongelijkheden opstellen </lang>+            <lang id="de">Gleichungen und Ungleichungen</lang>+        </title>+        <description>+            <lang id="en">+                Set up expressions, equations and inequalities in a problem situation within or outside mathematics.+            </lang>+            <lang id="fr">+                Produire des expressions, des équations et des inégalités lors de la résolution d’un problème intra ou extra mathématique.+            </lang>+            <lang id="nl">+                Stel uitdrukkingen, vergelijkingen en ongelijkheden op bij een probleemsituatie binnen of buiten de wiskunde. +            </lang>+            <lang id="de">+                Bestimme Ausdrücke, Gleichungen und Ungleichungen in einer Aufgabenstellung innerhalb oder außerhalb der Mathematik.+            </lang>+        </description>+    </node>+    <node id="R11">+        <title>+            <lang id="en">Set up numerical expressions</lang>+            <lang id="fr">Produire des expressions numériques</lang>+            <lang id="nl">Numerieke uitdrukkingen opstellen</lang>+            <lang id="de">Numerische Ausdrücke </lang>+        </title>+        <description>+            <lang id="en">+                Set up numerical expressions in a problem situation, that is, expressions containing just numbers and operations.+            </lang>+            <lang id="fr">+                Produire des expressions numériques lors de la résolution d’un problème,  c'est-à-dire des expressions ne contenant que des nombres et des opérations.+            </lang>+            <lang id="nl">+                Stel numerieke uitdrukkingen op bij een probleemsituatie, wat wil zeggen,  expressies die alleen getallen en bewerkingen bevatten.+            </lang>+            <lang id="de">+                Bestimme numerische Ausdrücke in einer Aufgabenstellung, d. h., Ausdrücke die nur aus Zahlen und Operation bestehen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Setting up an expression without using variables: ((&lt;number&gt; + 8)*3 - 4 + &lt;number&gt;)/4 + 2 – &lt;number&gt;+            </lang>+            <lang id="fr">+                Produire une expression sans utiliser de variables: ((&lt;numéro&gt; + 8) * 3 - 4 + &lt;nombre&gt;) / 4 + 2 - &lt;nombre&gt;)+            </lang>+            <lang id="nl">+                Stel een uitdrukking op zonder variabelen te gebruiken: ((&lt;getal&gt; + 8)*3 - 4 + &lt;getal&gt;)/4 + 2 – &lt;getal&gt;+            </lang>+            <lang id="de">+                Formuliere einen Ausdruck ohne Variablen zu nutzen: ((&lt;Zahl&gt; + 8)*3 - 4 + &lt;Zahl&gt;)/4 + 2 – &lt;Zahl&gt;+            </lang>+        </example>+    </node>+    <node id="R12">+        <title>+            <lang id="en">Set up algebraic equations</lang>+            <lang id="fr">Mettre en équation</lang>+            <lang id="nl">Algebraïsche vergelijkingen opstellen </lang>+            <lang id="de">Algebraische Gleichungen </lang>+        </title>+        <description>+            <lang id="en">+                Set up algebraic equations in a problem situation, that is, equations containing variables, numbers and operations.+            </lang>+            <lang id="fr">+                Produire des équations algébriques lors de la résolution d’un problème,  c'est-à-dire des équations contenant des inconnues, des nombres et des  opérations.+            </lang>+            <lang id="nl">+                Stel algebraïsche vergelijkingen op bij een probleemsituatie, dat wil  zeggen, vergelijkingen die variabelen, getallen en operaties bevatten.+            </lang>+            <lang id="de">+                Bestimme eine algebraische Gleichung in einer Aufgabenstellung, d. h., Gleichungen mit Variablen, Zahlen und Operationen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up the equation 4 + 3n = 50+            </lang>+            <lang id="fr">+                Produire l'équation 4 + 3n = 50+            </lang>+            <lang id="nl">+                Stel de vergelijking 4 + 3n = 50 op.+            </lang>+            <lang id="de">+                Formuliere die Gleichung: 4 + 3n = 50+            </lang>+        </example>+    </node>+    <node id="R121">+        <title>+            <lang id="en">Set up algebraic expressions</lang>+            <lang id="fr">Produire des expressions algébriques</lang>+            <lang id="nl">Algebraïsche uitdrukkingen opstellen</lang>+            <lang id="de">Algebraische Ausdrücke </lang>+        </title>+        <description>+            <lang id="en">+                Set up algebraic expressions in a problem situation, that is, equations containing variables, numbers and operations.+            </lang>+            <lang id="fr">+                Produire des expressions algébriques lors de la résolution d’un  problème, c'est-à-dire des expressions contenant des variables, des nombres et des opérations.+            </lang>+            <lang id="nl">+                Stel algebraïsche uitdrukkingen op bij een probleemsituatie, dat wil zeggen, uitdrukkingen die variabelen, getallen en operaties bevatten.+            </lang>+            <lang id="de">+                Bestimme einen algebraischen Ausdruck in einer Aufgabenstellung, d. h., Ausdrücke mit Variablen, Zahlen und Operationen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up the expression 4 + 3n+            </lang>+            <lang id="fr">+                Produire l'expression 4 + 3n+            </lang>+            <lang id="nl">+                Stel de uitdrukking 4 + 3n op.+            </lang>+            <lang id="de">+                Formuliere den Ausdruck: 4 + 3n+            </lang>+        </example>+    </node>++    <node id="R1211">+        <title>+            <lang id="en">Choose variables</lang>+            <lang id="fr">Choisir des variables</lang>+            <lang id="nl">Variabelen kiezen </lang>+            <lang id="de">Variablen</lang>+        </title>+        <description>+            <lang id="en">+                Define variables for a quantity or an unknown in a problem situation.+            </lang>+            <lang id="fr">+                Définir des variables pour représenter une quantité ou une inconnue  lors de la résolution d’un problème.+            </lang>+            <lang id="nl">+                Definieer variabele voor hoeveelheden of onbekenden in een  probleemsituatie.+            </lang>+            <lang id="de">+                Definiere Variablen für eine unbekannte Zahl oder eine Menge in einer Aufgabenstellung.+            </lang>+        </description>+    </node>+    <node id="R1212">+        <title>+            <lang id="en">Set up geometric model</lang>+            <lang id="fr">Produire un modèle géométrique</lang>+            <lang id="nl">Meetkundige modellen opstellen </lang>+            <lang id="de">Geometrisches Modell </lang>+        </title>+        <description>+            <lang id="en">+                Set up a geometric model.+            </lang>+            <lang id="fr">+                Produire un modèle géométrique.+            </lang>+            <lang id="nl">+                Stel een meetkundig model op.+            </lang>+            <lang id="de">+                Stelle ein geometrisches Modell auf.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up an algebraic expression for the length of hypotenuse: h = sqrt(a^2 + b^2)+            </lang>+            <lang id="fr">+                Définir une expression algébrique pour la longueur de l'hypoténuse : h = sqrt (a ^ 2 + b ^ 2)+            </lang>+            <lang id="nl">+                Stel een algebraïsche uitdrukking op voor de lengte van de schuine zijde: h = sqrt(a^2 + b^2)+            </lang>+            <lang id="de">+                Stelle den Ausdruck zur Bestimmung der Länge der Hypotenuse dar: h = sqrt(a^2 + b^2)+            </lang>+        </example>+    </node>+    <node id="R1213">+        <title>+            <lang id="en">Set up linear model</lang>+            <lang id="fr">Produire un modèle linéaire</lang>+            <lang id="nl">Een lineair model opstellen</lang>+            <lang id="de">Lineares Modell </lang>+        </title>+        <description>+            <lang id="en">+                Set up a linear model, that is, a model consisting of expressions, equations or inequalities of degree 1.+            </lang>+            <lang id="fr">+                Produire un modèle linéaire, c’est-à-dire un modèle mis en jeu pour produire des expressions, des équations ou des inéquations de degré 1.+            </lang>+            <lang id="nl">+                Stel een lineair model op, dat wil zeggen, een model dat eerstegraads uitdrukkingen, vergelijkingen of ongelijkheden bevat.+            </lang>+            <lang id="de">+                Stelle ein lineares Modell auf, d. h., ein Modell bestehend aus Ausdrücken, Gleichungen oder Ungleichungen 1. Grades. +            </lang>+        </description>+        <example>+            <lang id="en">+                Set up the linear model p = 30 + 4n+            </lang>+            <lang id="fr">+                Produire le modèle linéaire p = 30 + 4n+            </lang>+            <lang id="nl">+                Stel het lineaire model p = 30 + 4n op.+            </lang>+            <lang id="de">+                Formuliere das Modell: p = 30 + 4n+            </lang>+        </example>+    </node>+    <node id="R1214">+        <title>+            <lang id="en">Set up quadratic model</lang>+            <lang id="fr">Produire un modèle quadratique</lang>+            <lang id="nl">Een kwadratisch model opstellen</lang>+            <lang id="de">Quadratisches Modell </lang>+        </title>+        <description>+            <lang id="en">+                Set up a quadratic model, that is, a model consisting of expressions,  equations or inequalities of degree 2.+            </lang>+            <lang id="fr">+                Produire un modèle quadratique, c'est-à-dire un modèle mis en jeu pour      produire des expressions, des équations ou des inéquations de degré 2.+            </lang>+            <lang id="nl">+                Stel een kwadratisch model op, dat wil zeggen, een model dat  tweedegraads uitdrukkingen, vergelijkingen of ongelijkheden bevat.+            </lang>+            <lang id="de">+                Formuliere ein quadratisches Modell, d. h., ein Modell bestehend aus Ausdrücken, Gleichungen oder Ungleichungen 2. Grades.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up a model for the area of a square: a^2+            </lang>+            <lang id="fr">+                Produire un modèle pour l’aire d’un carré : a ^ 2+            </lang>+            <lang id="nl">+                Stel het model op voor de oppervlakte van een vierkant: a^2+            </lang>+            <lang id="de">+                Formuliere ein Model für die Fläche eines Quadrats: a^2+            </lang>+        </example>+    </node>+    <node id="R1215">+        <title>+            <lang id="en">Set up exponential model</lang>+            <lang id="fr">Produire un modèle exponentiel</lang>+            <lang id="nl">Een exponentieel model opstellen	</lang>+            <lang id="de">Stelle eine Exponentialfunktion auf</lang>+        </title>+        <description>+            <lang id="en">+                Set up an exponential model, that is, a model consisting of expressions, equations or inequalities in which the variable is in an exponent.+            </lang>+            <lang id="fr">+                Produire un modèle exponentiel, c'est-à-dire un modèle mis en jeu pour produire des expressions, des équations ou des inéquations dans  lesquelles la variable est en exposant.+            </lang>+            <lang id="nl">+                Stel een exponentieel model op, dat wil zeggen, een model dat uitdrukkingen, vergelijkingen of ongelijkheden bevat waarin de variabele in de                  exponent staat.+            </lang>+            <lang id="de">+                Stelle eine Exponentialfunktion auf, d. h., ein Modell bestehend aus Ausdrücken, Gleichungen oder Ungleichungen in dem die Variable im Exponenten  steht.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up the exponential model: h = 32 * 0.75^(n-1)+            </lang>+            <lang id="fr">+                Produire le modèle exponentiel : h = 32 * 0.75 ^ (n-1)+            </lang>+            <lang id="nl">+                Stel het exponentiële model h = 32 * 0.75^(n-1) op.+            </lang>+            <lang id="de">+                Formuliere die Exponentialfunktion: h = 32 * 0.75^(n-1)+            </lang>+        </example>+    </node>+    <node id="R13">+        <title>+            <lang id="en">Set up algebraic inequalities</lang>+            <lang id="fr">Produire des inéquations algébriques</lang>+            <lang id="nl">Algebraïsche ongelijkheden opstellen </lang>+            <lang id="de">Algebraische Ungleichungen </lang>+        </title>+        <description>+            <lang id="en">+                Set up algebraic inequalities, so inequalities containing variables, numbers and operations.+            </lang>+            <lang id="fr">+                Produire des inéquations algébriques, donc des inégalités contenant des  variables, des nombres et des opérations.+            </lang>+            <lang id="nl">+                Stel algebraïsche ongelijkheden op, dat wil zeggen ongelijkheden die  variabelen, getallen en operaties bevatten.+            </lang>+            <lang id="de">+                Stelle algebraische Ungleichungen auf, also Ungleichungen mit Variablen, Nummern und Operationen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Set up the inequality 4 + 3n &gt; 50+            </lang>+            <lang id="fr">+                Produire l'inéquation 4 + 3n&gt; 50+            </lang>+            <lang id="nl">+                Stel de ongelijkheid 4 + 3n &gt; 50 op.+            </lang>+            <lang id="de">+                Formuliere die Ungleichung: 4 + 3n &gt; 50 +            </lang>+        </example>++    </node>+    <node id="R3">+        <title>+            <lang id="en">Simplify algebraic expressions and solve equations</lang>+            <lang id="fr">Simplifier des expressions algébriques et résoudre des équations</lang>+            <lang id="nl">Algebraïsche uitdrukkingen vereenvoudigen en vergelijkingen oplossen</lang>+            <lang id="de">Vereinfachung algebraischer Ausdrücke und Gleichungen</lang>+        </title>+        <description>+            <lang id="en">+                Work towards a solution of a problem by simplifying algebraic expressions and solving equations.+            </lang>+            <lang id="fr">+                Résoudre un problème en simplifiant des expressions algébriques et en  résolvant des équations+            </lang>+            <lang id="nl">+                Werk naar de oplossing van een probleem toe door algebraïsche  uitdrukkingen te vereenvoudigen en vergelijkingen op te lossen.+            </lang>+            <lang id="de">+                Finde eine Lösung der Aufgaben durch Vereinfachung algebraischer Ausdrücke  und Auflösen von Ausdrücken.+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify 3 + 5n = 7 – 2n into 7n = 4.+            </lang>+            <lang id="fr">+                Simplifier 3 + 5n = 7 - 2n  en  7n = 4.+            </lang>+            <lang id="nl">+                Vereenvoudig 3 + 5n = 7 – 2n tot 7n = 4.+            </lang>+            <lang id="de">+                Vereinfache 3 + 5n = 7 – 2n zu 7n = 4.+            </lang>+        </example>+    </node>+    <node id="R31">+        <title>+            <lang id="en">Use numerical expressions</lang>+            <lang id="fr">Utiliser des expressions numériques</lang>+            <lang id="nl">Numerieke uitdrukkingen gebruiken</lang>+            <lang id="de">Numerische Ausdrücke </lang>+        </title>+        <description>+            <lang id="en">+                Use numerical expressions, that is, expressions without variables, while solving a problem.+            </lang>+            <lang id="fr">+                Utiliser des expressions numériques, c'est-à-dire des expressions sans  variables, lors de la résolution d’un problème.+            </lang>+            <lang id="nl">+                Gebruik numerieke uitdrukkingen, dat wil zeggen, uitdrukkingen zonder variabelen, bij het oplossen van een probleem.+            </lang>+            <lang id="de">+                Verwende zum Lösen der Aufgabe numerische Ausdrücke, d. h. Ausdrücke ohne Variablen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Carry out a numerical calculation: 20.00 + 0.25 * 92 = 43.00+            </lang>+            <lang id="fr">+                Effectuer un calcul numérique : 20,00 + 0,25 * 92 = 43,00+            </lang>+            <lang id="nl">+                Voer een numerieke berekening uit: 20.00 + 0.25 * 92 = 43.00+            </lang>+            <lang id="de">+                Führe eine numerische Berechnung durch: 20.00 + 0.25 * 92 = 43.00+            </lang>+        </example>+    </node>+    <node id="R32">+        <title>+            <lang id="en">Solve equations</lang>+            <lang id="fr">Résoudre des équations</lang>+            <lang id="nl">Vergelijkingen oplossen</lang>+            <lang id="de">Gleichungen lösen</lang>+        </title>+        <description>+            <lang id="en">+                Work towards a solution of a problem using algebra.+            </lang>+            <lang id="fr">+                Résoudre un problème en utilisant l'algèbre.+            </lang>+            <lang id="nl">+                Werk naar een oplossing van een probleem toe door algebra te gebruiken.+            </lang>+            <lang id="de">+                Finde eine Lösung der Aufgaben durch Anwendung von Algebra.+            </lang>+        </description>+    </node>+    <node id="R321">+        <title>+            <lang id="en">Substitute</lang>+            <lang id="fr">Substituer</lang>+            <lang id="nl">Substitutie </lang>+            <lang id="de">Substitution</lang>+        </title>+        <description>+            <lang id="en">+                Substitute a number or an expression for a variable.+            </lang>+            <lang id="fr">+                Substituer un nombre ou une expression à une variable.+            </lang>+            <lang id="nl">+                Substitueer een getal of een uitdrukking voor een variabele.+            </lang>+            <lang id="de">+                Substituiere eine Zahl oder einen Ausdruck für eine Variable.+            </lang>+        </description>+    </node>+    <node id="R322">+        <title>+            <lang id="en">Simplify expressions</lang>+            <lang id="fr">Simplifier des expressions</lang>+            <lang id="nl">Uitdrukkingen vereenvoudigen</lang>+            <lang id="de">Vereinfachung von Ausdrücken </lang>+        </title>+        <description>+            <lang id="en">+                Work toward a solution of a problem by simplifying algebraic expressions.+            </lang>+            <lang id="fr">+                Résoudre un problème en simplifiant des expressions algébriques.+            </lang>+            <lang id="nl">+                Werk naar een oplossing van een probleem toe door algebraïsche uitdrukkingen te vereenvoudigen.+            </lang>+            <lang id="de">+                Finde eine Lösung der Aufgaben durch Vereinfachung des algebraischen Ausdrucks.+            </lang>+        </description>+    </node>+    <node id="R3221">+        <title>+            <lang id="en">Expand expressions</lang>+            <lang id="fr">Développer des expressions</lang>+            <lang id="nl">Haakjes in uitdrukkingen wegwerken</lang>+            <lang id="de">Auflösen </lang>+        </title>+        <description>+            <lang id="en">+                Expand the expression to remove brackets.+            </lang>+            <lang id="fr">+                Développer une expression pour supprimer les parenthèses.+            </lang>+            <lang id="nl">+                Werk haakjes weg in de uitdrukking.+            </lang>+            <lang id="de">+                Löse den Ausdruck auf, um die Klammer zu entfernen.+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify (4x+20)/4 into x + 5+            </lang>+            <lang id="fr">+                Simplifier (4x + 20) / 4  en  x + 5+            </lang>+            <lang id="nl">+                Vereenvoudig (4x+20)/4 tot x + 5+            </lang>+            <lang id="de">+                Vereinfache (4x+20)/4 zu x + 5+            </lang>+        </example>+    </node>+    <node id="R3222">+        <title>+            <lang id="en">Divide out common factors</lang>+            <lang id="fr">Diviser par des facteurs communs</lang>+            <lang id="nl">Gemeenschappelijke factoren uitdelen</lang>+            <lang id="de">Dividiere gemeinsame Faktoren</lang>+        </title>+        <description>+            <lang id="en">+                Divide out common factors in an expression+            </lang>+            <lang id="fr">+                Diviser par des facteurs communs une expression+            </lang>+            <lang id="nl">+                Deel gemeenschappelijke factoren uit in een uitdrukking.+            </lang>+            <lang id="de">+                Dividiere gemeinsame Faktoren eines Ausdrucks+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify 10x / 2 into 5x+            </lang>+            <lang id="fr">+                Simplifier 10x / 2  en  5x+            </lang>+            <lang id="nl">+                Vereenvoudig 10x / 2 tot 5x+            </lang>+            <lang id="de">+                Vereinfache 10x / 2 zu 5x+            </lang>+        </example>+    </node>+    <node id="R3223">+        <title>+            <lang id="en">Combine like terms</lang>+            <lang id="fr">Combiner des termes similaires</lang>+            <lang id="nl">Soortgelijke termen combineren </lang>+            <lang id="de">Fasse gleiche Terme zusammen </lang>+        </title>+        <description>+            <lang id="en">+                Add or subtract like terms in an expression+            </lang>+            <lang id="fr">+                Ajouter ou soustraire des termes similaires dans une expression  algébrique+            </lang>+            <lang id="nl">+                Tel soortgelijke termen op of trek ze af in een uitdrukking+            </lang>+            <lang id="de">+                Addiere oder subtrahiere gleiche Termglieder eines Ausdrucks+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify 3x + 20 + x into 4x + 20+            </lang>+            <lang id="fr">+                Simplifier 3x + 20 + x  en  4x + 20+            </lang>+            <lang id="nl">+                Vereenvoudig 3x + 20 + x tot 4x + 20+            </lang>+            <lang id="de">+                Vereinfache 3x + 20 + x zu 4x + 20+            </lang>+        </example>+    </node>+    <node id="R323">+        <title>+            <lang id="en">Simplify by addition and subtraction</lang>+            <lang id="fr">Simplifier par addition et soustraction</lang>+            <lang id="nl">Vereenvoudigen door optellen en aftrekken</lang>+            <lang id="de">Vereinfache durch Addition und Subtraktion</lang>+        </title>+        <description>+            <lang id="en">+                Add or subtract like terms in an equation or inequality+            </lang>+            <lang id="fr">+                Ajouter ou soustraire des termes similaires dans une équation ou une  inéquation+            </lang>+            <lang id="nl">+                Tel soortgelijke termen op of trek ze af in een vergelijking of  ongelijkheid.+            </lang>+            <lang id="de">+                Addiere oder subtrahiere like Terme einer Gleichung+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify 5x = 2x + 6 into 3x = 6+            </lang>+            <lang id="fr">+                Simplifier 5x = 2x + 6  en  3x = 6+            </lang>+            <lang id="nl">+                Vereenvoudig 5x = 2x + 6 tot 3x = 6+            </lang>+            <lang id="de">+                Vereinfache 5x = 2x + 6 zu 3x = 6+            </lang>+        </example>+    </node>+    <node id="R324">+        <title>+            <lang id="en">Simplify by multiplication and division</lang>+            <lang id="fr">Simplifier par multiplication et division</lang>+            <lang id="nl">Vereenvoudigen door vermenigvuldigen en delen </lang>+            <lang id="de">Vereinfache durch Multiplikation und Division</lang>+        </title>+        <description>+            <lang id="en">+                Multiply or divide common factors in an equation or inequality+            </lang>+            <lang id="fr">+                Multiplier ou diviser par des facteurs communs dans une équation, par  des facteurs communs non nuls dans une inéquation+            </lang>+            <lang id="nl">+                Vermenigvuldig of deel gemeenschappelijke factoren in een vergelijking of ongelijkheid.+            </lang>+            <lang id="de">+                Multipliziere oder dividiere gemeinsam Faktoren einer Gleichung+            </lang>+        </description>+        <example>+            <lang id="en">+                Simplify 3x = 6 into x = 2+            </lang>+            <lang id="fr">+                Simplifier 3x = 6  en  x = 2+            </lang>+            <lang id="nl">+                Vereenvoudig 3x = 6 tot x = 2+            </lang>+            <lang id="de">+                Vereinfache 3x = 6 zu x = 2+            </lang>+        </example>+    </node>+</nodes>
+ src/Bayes/EliminationOrdering.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.EliminationOrdering 
+   ( EliminationOrdering, nextVariable
+   , simpleOrder, staticOrder, minFactorOrder, minFactorVars
+   ) where
+
+import Bayes.Factor
+import Data.List
+
+-- depends on 'factors' and 'keeps'
+newtype EliminationOrdering = Elim { fromElim :: [Dimensions] -> [String] -> Maybe (String, EliminationOrdering) }
+
+nextVariable :: EliminationOrdering -> [Factor] -> [String] -> Maybe (String, EliminationOrdering)
+nextVariable (Elim f) fs = f (map dimensions fs)
+
+simpleOrder :: EliminationOrdering
+simpleOrder = Elim $ \ds keeps -> 
+   case filter (`notElem` keeps) (vars ds) of
+      []  -> Nothing
+      y:_ -> Just (y, simpleOrder)
+
+staticOrder :: [String] -> EliminationOrdering
+staticOrder xs = Elim $ \ds keeps -> 
+   let rec [] = fromElim simpleOrder ds keeps
+       rec (y:ys) 
+          | y `elem` keeps = rec ys
+          | otherwise      = Just (y, staticOrder ys)
+   in rec xs
+
+minFactorOrder :: EliminationOrdering
+minFactorOrder = Elim $ \ds keeps -> 
+   case minFactorNext (`notElem` keeps) ds of
+      Just v  -> Just (v, minFactorOrder)
+      Nothing -> Nothing
+
+minFactorNext :: (String -> Bool) -> [Dimensions] -> Maybe String
+minFactorNext p ds =
+   case sortOn fst (map f vs) of
+      [] -> Nothing
+      (_, v):_ -> Just v
+ where
+   vs  = filter p (vars ds)
+   f v = let xs  = filter (hasVarD v) ds
+             res = mergesD xs
+         in (size res - size xs, v)
+
+-- |elimination order of variables corresponding to the min-factor heuristic
+minFactorVars :: [Factor] -> [String]
+minFactorVars fs = 
+   case minFactorNext (const True) (map dimensions fs) of 
+      Just v  -> v : minFactorVars (eliminate fs v)
+      Nothing -> []
+ src/Bayes/Evidence.hs view
@@ -0,0 +1,338 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Evidence
+   ( Evidence, getIndex, set, setN, setId, clear
+   , virtual, addVirtualNodes, fromEvidenceTp
+   , EvidenceType(..), virtualId, filterEvidence
+   , evidenceMap
+   , evStates
+   , hardEvidence
+        -- * Evidence
+   , (.==)
+   , (.=~)
+   , newEvidence, evidenceIndex, fromEvidence, allProbabilities
+   , evidenceOfAbsence
+   , nodeNotSet
+   , nodeIsSet
+   , nodeSetTo
+   , noVirtuals
+   , isEmpty, getNames
+     -- * Probabilities
+   , Probabilities, fromProbabilities, makeProbabilities, findProbability
+   , probabilitiesFor
+   , renameEvidence
+   ) where
+
+import Bayes.Probability
+import Bayes.Network
+import qualified Data.Map as M
+import Control.Monad (forM)
+import Control.Arrow
+import Data.List
+import Data.Maybe
+import Data.Semigroup
+import Ideas.Utils.Parsing
+import Ideas.Utils.Prelude (readM)
+
+import qualified Ideas.Text.XML as XML
+
+-- | Evidence is associated to some node in a network by a string. It carries
+--   either an index of the state that we say we have evidence for (hard
+--   evidence) or a probability for each state of the node (virtual evidence)
+newtype Evidence = E { evidenceMap :: M.Map String EvidenceType }
+ deriving (Eq, Ord)
+
+instance Show Evidence where
+   show = intercalate ", " . map f . fromEvidenceTp
+    where
+      f (s, et) = s ++ "=" ++ show et
+
+instance Read Evidence where
+   readsPrec _ = either (const []) (\a -> [(a, "")]) . parseSimple pEvidence
+
+pEvidence :: Parser Evidence
+pEvidence = mconcat <$> sepBy pItem (char ',' <* spaces) <* spaces
+
+pItem :: Parser Evidence
+pItem = flip ($) <$> identifier <* char '=' <*> pType
+
+pType :: Parser (String -> Evidence)
+pType =  flip evidenceIndex <$ char '#' <*> pNat
+     <|> flip virtualId     <$ char '[' <*> sepBy pPair (char ',' <* spaces) <* char ']'
+
+pPair :: Parser (String, Probability)
+pPair = (,) <$> identifier <* char ':' <*> pProbability
+
+pProbability :: Parser Probability
+pProbability = fromRational . toRational <$> pDouble <* char '%'
+
+pDouble :: Parser Double
+pDouble = (\x y -> read (x ++ "." ++ y) / 100) <$> many1 digit <* char '.' <*> many1 digit
+
+pNat :: Parser Int
+pNat = read <$> many1 digit
+
+identifier :: Parser String
+identifier = many (alphaNum <|> oneOf "-_")
+
+
+instance Semigroup Evidence where
+   E m1 <> E m2 = E (m1 <> m2)
+
+data EvidenceType = Index Int | Virtual [(String, Probability)]
+ deriving (Eq, Ord)
+
+instance Show EvidenceType where
+   show (Index i)    = '#' : show i
+   show (Virtual xs) = '[' : intercalate ", " (map f xs) ++ "]"
+    where
+      f (s, p) = s ++ ":" ++ show p
+
+instance Monoid Evidence where
+   mempty = E mempty
+   E m1 `mappend` E m2 = E (m1 `mappend` m2)
+
+fromEvidenceTp :: Evidence -> [(String, EvidenceType)]
+fromEvidenceTp = M.toList . evidenceMap
+
+getIndex :: Node a -> Evidence -> Maybe Int
+getIndex n (E m) =
+   case M.lookup (nodeId n) m of
+      Just (Index i) -> Just i
+      _              -> Nothing
+
+virtual :: Node a -> [Probability] -> Evidence
+virtual n ps = virtualId (nodeId n) (zip (map fst (states n)) ps)
+
+virtualId :: String -> [(String, Probability)] -> Evidence
+virtualId s ps = -- setId ('#' : s) 0 $
+   E (M.singleton s (Virtual ps))
+
+set :: Node a -> Int -> Evidence -> Evidence
+set = setId . nodeId
+
+setId :: String -> Int -> Evidence -> Evidence
+setId s i (E m) = E $ M.insert s (Index i) m
+
+setN :: [Node a] -> [Int] -> Evidence -> Evidence
+setN ns as ev = foldr (uncurry set) ev (zip ns as)
+
+clear :: Node a -> Evidence -> Evidence
+clear n (E m) = E $ M.delete (nodeId n) m
+
+filterEvidence :: (String -> Bool) -> Evidence -> Evidence
+filterEvidence p (E m) = E (M.filterWithKey (const . p) m)
+
+addVirtualNodes :: Evidence -> Network () -> Network ()
+addVirtualNodes (E m) = foldr add id (M.toList m)
+ where
+   add (s, Virtual ps) = (. addNode (observedNode s ps))
+   add _ = id
+
+observedNode :: String -> [(String, Probability)] -> Node ()
+observedNode s ps = (node ('#' : s))
+   { states     = [("yes", ()), ("no", ())]
+   , parentIds  = [s]
+   , definition = CPT $ concatMap (\(_, x) -> [x, 1-x]) ps
+   }
+
+noVirtuals :: Evidence -> Evidence
+noVirtuals (E m) = E (M.filter isIndex m)
+ where
+   isIndex (Index _) = True
+   isIndex _ = False
+
+--------------------------------------------------------------------------------
+-- EXTRA
+
+---------------------------------------------------------------------------
+-- Evidence
+
+-- | Evidence is associated to some node in a network by a string
+--   It carries either an index of the state that we say we have evidence of
+--   or a probability for each state of the node
+{-
+newtype Evidence = E { evidenceMap :: M.Map String (Either Int Probabilities) }
+
+instance Show Evidence where
+   show = intercalate ", " . map f . fromEvidence
+    where
+      f (s, et) = s ++ "=" ++ either (('#':) . show) show et
+
+instance Semigroup Evidence where
+   E m1 <> E m2 = E (m1 <> m2)
+
+instance Monoid Evidence where
+   mempty  = E M.empty
+   mappend = (<>)
+
+instance ToHTML Evidence where
+   toHTML e
+      | isEmpty e = mempty
+      | otherwise = w3table True $ header : map f (fromEvidence e)
+    where
+      header   = map string ["id", "value"]
+      f (s, v) = [string s, either (text . toBool) toHTML v]
+      toBool = (== 0)
+-}
+newEvidence :: String -> Probabilities -> Evidence
+newEvidence s xs = virtualId s (map (second fromRational) (fromProbabilities xs))
+
+(.==) :: Eq a => Node a -> a -> Evidence
+n .== a = evidenceIndex (nodeId n) (fromMaybe 0 (findIndex f (states n)))
+ where
+   f = (== a) . snd
+
+-- | Soft evidence counterpart to .==
+(.=~) :: Eq a => Node a -> [Probability] -> Evidence
+(.=~) = virtual
+
+-- | Set a particular node to a default value if it is absent.
+evidenceOfAbsence :: Eq a => Node a -> a -> Evidence -> Evidence
+evidenceOfAbsence n def ev = if nodeNotSet n ev then n .== def <> ev else ev
+
+-- | Return true if a node has no state in the given evidence.
+nodeNotSet :: Node a -> Evidence -> Bool
+nodeNotSet n ev = isNothing $ getIndex n ev
+
+nodeIsSet :: Node a -> Evidence -> Bool
+nodeIsSet n = not . nodeNotSet n
+
+-- | Query whether a node is in a certain hard state in the evidence.
+nodeSetTo :: Eq a => Node a -> a -> Evidence -> Bool
+nodeSetTo n state ev = expectedIndex == actualIndex
+
+   where
+   expectedIndex = findIndex ((== state) . snd) (states n)
+   actualIndex = getIndex n ev
+
+
+evidenceIndex :: String -> Int -> Evidence
+evidenceIndex s i = setId s i mempty
+
+fromEvidence :: Evidence -> [(String, Either Int Probabilities)]
+fromEvidence = map (second f) . fromEvidenceTp
+ where
+   f (Index i)    = Left i
+   f (Virtual xs) = Right (makeProbabilities $ map (second toRational) xs)
+
+allProbabilities :: Evidence -> [(String, String, Rational)]
+allProbabilities ev =
+   [ (n, s, r)
+   | (n, v) <- fromEvidence ev
+   , (s, r) <- either (const []) fromProbabilities v
+   ]
+
+--filterEvidence :: (String -> Bool) -> Evidence -> Evidence
+--filterEvidence = undefined --  p (E m) = E (M.filterWithKey (const . p) m)
+
+isEmpty :: Evidence -> Bool
+isEmpty = null . fromEvidence
+
+getNames :: Evidence -> [String]
+getNames = map fst . fromEvidence
+
+
+-- | Evidence is recorded as a mapping from node names to probabilities of
+-- being in a certain state. This function obtains a pairing of strings of the
+-- form "<NODE>#<STATE>" to a number from 0 to 1.
+evStates :: Evidence -> [(String, Double)]
+evStates = map (\(node', state, prob) -> (node' ++ "#" ++ state, fromRational prob)) . allProbabilities 
+
+
+-- | Obtain the states of the hard evidence.
+hardEvidence :: Evidence -> [(String, Int)] 
+hardEvidence = foldl' f [] . fromEvidence
+
+   where
+   f xs (node, Left  i)  = (node, i):xs
+   f xs (node, Right ps) = xs
+
+---------------------------------------------------------------------------
+-- Probabilities
+
+newtype Probabilities = P (M.Map String Rational)
+   deriving Show
+
+{-
+instance ToHTML Probabilities where
+  toHTML (P m) = table $ tr $ map (left . td . f) $ M.toList m
+   where
+     f (n, b) = string (n ++ ": " ++ show (fromRational b :: Double)) -}
+
+makeProbabilities :: [(String, Rational)] -> Probabilities
+makeProbabilities = P . M.fromList
+
+fromProbabilities :: Probabilities -> [(String, Rational)]
+fromProbabilities (P m) = M.toList m
+
+findProbability :: Probabilities -> String -> Maybe Rational
+findProbability (P m) s = M.lookup s m
+
+-- | Obtain the probabilities for soft evidence at a particular node.
+probabilitiesFor :: Evidence -> String -> Maybe [(String, Probability)]
+probabilitiesFor ev identifier = do
+   states <- M.lookup identifier $ evidenceMap ev
+   case states of
+      Index _ -> Nothing
+      Virtual xs -> Just xs
+
+renameEvidence :: (String -> String) -> Evidence -> Evidence
+renameEvidence f (E m) = E $ M.mapKeys f m
+
+-------------------------------------------------------------------------------
+
+
+instance XML.ToXML Evidence where
+   toXML = XML.makeXML "evidence"
+         . mconcat
+         . map (uncurry f)
+         . M.toList 
+         . evidenceMap
+
+      where 
+      f :: String -> EvidenceType -> XML.XMLBuilder
+      f lbl (Index i) = 
+         XML.element "hard"
+            [ "label" XML..=. lbl
+            , XML.tag "state" ("value" XML..=. show i)
+            ]
+      f lbl (Virtual is) = 
+         XML.element "soft"
+            [ "label" XML..=. lbl
+            , mconcat [ XML.element "state" 
+                           [ "value" XML..=. k
+                           , "probability" XML..=. show v 
+                           ] | (k, v) <- is ]
+            ]
+
+instance XML.InXML Evidence where
+   fromXML xml
+      | XML.name xml /= "evidence" = fail "expecting <evidence> tag"
+      | otherwise = do
+           xs <- mapM getHard (XML.findChildren "hard" xml)
+           ys <- mapM getSoft (XML.findChildren "soft" xml)
+           return $ E $ M.fromList $ xs ++ ys
+    where
+      getHard xml = do
+         lbl <- XML.findAttribute "label" xml
+         value <- XML.findChild "state" xml >>= XML.findAttribute "value" >>= readM
+         return $ (lbl, Index value)
+
+      getSoft xml = do
+         lbl <- XML.findAttribute "label" xml
+         states' <- forM (XML.findChildren "state" xml) $ \child' -> do
+               probability <- XML.findAttribute "probability" child' >>= (either fail return . parseSimple pProbability)
+               value <- XML.findAttribute "value" child'
+               return (value, probability)
+         return $ (lbl, Virtual states')
+ src/Bayes/Factor.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE MagicHash #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Factor 
+   ( -- * Factor type and dimensions
+     Factor
+   , Dimensions, dimensions, fromDimensions, hasVarD, mergesD
+   , Dimensional(..)
+     -- * Construction
+   , makeFactor
+     -- * Simple queries
+   , values
+     -- * Standard operations
+   , multiply, sumout, sumouts, condition, conditions, normalize
+     -- * Variable elimination on factors
+   , eliminate, eliminateSplit, eliminateList
+   ) where
+
+import Data.List
+import Data.Maybe
+import Data.Semigroup
+import GHC.Exts
+import qualified Data.Set as S
+
+data Factor = F { dimensions :: Dimensions, getTree :: Tree }
+
+instance Show Factor where
+   show (F d t) = intercalate "," (map showDim (fromDimensions d)) ++ ": " ++ show t
+    where
+      showDim (s, n) = s ++ "[" ++ show n ++ "]" 
+
+instance Semigroup Factor where
+   (<>) = multiply
+
+instance Monoid Factor where 
+   mempty  = makeFactor [] [1]
+   mappend = (<>)
+   mconcat = multiplyList
+
+makeFactor :: [(String, Int)] -> [Double] -> Factor
+makeFactor d bs = F (mkD dims) (reorder dims d $ makeTree (map snd d) bs)
+ where
+   dims = sort d
+
+makeTree :: [Int] -> [Double] -> Tree
+makeTree is = rec (reverse is) . map leaf
+ where
+   rec (2:ns) ts = rec ns $ groups2 ts
+   rec (3:ns) ts = rec ns $ groups3 ts
+   rec (n:ns) ts = rec ns $ groupsN n ts
+   rec [] [t]    = t
+   rec _ _       = error "makeFactor"
+
+{-# INLINE groups2 #-}
+groups2 :: [Tree] -> [Tree]
+groups2 [] = []
+groups2 (x:y:rest) = Two x y : groups2 rest
+groups2 _ = error "groups2"
+
+{-# INLINE groups3 #-}
+groups3 :: [Tree] -> [Tree]
+groups3 [] = []
+groups3 (x:y:z:rest) = Three x y z : groups3 rest
+groups3 _ = error "groups3"
+
+{-# INLINE groupsN #-}
+groupsN :: Int -> [Tree] -> [Tree]
+groupsN n = rec
+ where
+   rec xs 
+      | null xs   = []
+      | otherwise = Bin xs1 : rec xs2
+    where
+      (xs1, xs2) = splitAt n xs
+
+condition :: String -> Int -> Factor -> Factor
+condition s i (F d t) = F (deleteD s d) (set s i d t)
+
+conditions :: [(String, Int)] -> Factor -> Factor
+conditions xs (F d t) = F (deletesD (map fst xs) d) (choose xs d t)
+
+multiplyList :: [Factor] -> Factor
+multiplyList = rec
+ where
+   rec []  = mempty
+   rec [a] = a
+   rec [a,b] = multiply a b
+   rec as  = rec (best:rest)
+    where
+      m:ms    = sortBy cmp as
+      cmp x y = size x `compare` size y
+      (best, rest) = minimumBy (\x y -> size (fst x) `compare` size (fst y)) $ map make [0 .. length ms-1]
+
+      make i = (multiply m y, xs ++ ys)
+       where
+         (xs, y:ys) = splitAt i ms
+
+multiply :: Factor -> Factor -> Factor
+multiply (F d1 t1) (F d2 t2) = F (mergeD d1 d2) (mergeWith (*##) d1 d2 t1 t2)
+
+sumouts :: [String] -> Factor -> Factor
+sumouts vs0 (F dt t0) = F (deletesD vs0 dt) (rec (dropTail bools) t0)
+ where
+   ds    = map fst (fromDimensions dt)
+   bools = f (filter (`elem` ds) vs0) ds
+
+   f [] _  = []
+   f vs (x:xs) 
+      | x `elem` vs = True  : f (delete x vs) xs
+      | otherwise   = False : f vs xs
+   f _ _ = []
+
+   rec [] t = t
+   rec (b:bs) t
+      | b         = foldr1 (zipTree (+##)) (subtrees rt)
+      | otherwise = rt
+    where
+      rt = mapSubtrees (rec bs) t
+
+   dropTail = reverse . dropWhile not . reverse
+
+sumout :: String -> Factor -> Factor
+sumout = sumouts . return
+
+values :: Factor -> [Double]
+values = treeToList . getTree
+
+normalize :: Factor -> Factor
+normalize x = 
+   case sum (values x) of
+      D# total -> x { getTree = mapTree (/## total) (getTree x) }
+
+-----------------------------------------------------------------------------
+
+eliminate :: [Factor] -> String -> [Factor]
+eliminate fs = uncurry f . eliminateSplit fs
+ where
+   f x xs = if size x <= 1 then xs else x : xs
+
+eliminateList :: [Factor] -> [String] -> [Factor]
+eliminateList = foldl eliminate
+
+-- | Eliminate variable: returns new factor and remaining (unchanged) factors
+eliminateSplit :: [Factor] -> String -> (Factor, [Factor])
+eliminateSplit fs s = (sumout s (mconcat fs1), fs2)
+ where
+   (fs1, fs2) = partition (S.member s . varSet) fs
+
+-----------------------------------------------------------------------------
+
+class Dimensional a where
+   size   :: a -> Int
+   varSet :: a -> S.Set String
+   vars   :: a -> [String]
+   -- default
+   vars = S.toList . varSet
+
+instance Dimensional Factor where
+   size   = size . dimensions
+   varSet = varSet . dimensions
+
+instance Dimensional Dimensions where
+   size (D n _) = n
+   varSet = S.fromList . map fst . fromDimensions
+
+instance Dimensional a => Dimensional [a] where
+   size   = sum . map size
+   varSet = S.unions . map varSet
+
+---------------------------------------------------------
+
+data Dimensions = D Int [(String, Int)]
+
+fromDimensions :: Dimensions -> [(String, Int)]
+fromDimensions (D _ xs) = xs
+
+mkD :: [(String, Int)] -> Dimensions
+mkD xs = D (product (map snd xs)) xs
+
+deleteD :: String -> Dimensions -> Dimensions
+deleteD s = filterD (/= s)
+
+deletesD :: [String] -> Dimensions -> Dimensions
+deletesD xs = filterD (`notElem` xs)
+
+filterD :: (String -> Bool) -> Dimensions -> Dimensions
+filterD p (D _ m) = mkD (filter (p . fst) m)
+
+hasVarD :: String -> Dimensions -> Bool
+hasVarD s (D _ xs) = rec xs 
+ where
+   rec [] = False
+   rec ((x, _):rest) = 
+      case compare s x of 
+         LT -> False
+         EQ -> True 
+         GT -> rec rest
+
+mergeD :: Dimensions -> Dimensions -> Dimensions
+mergeD (D _ m1) (D _ m2) = mkD (rec m1 m2)
+ where
+   rec lx@(x:xs) ly@(y:ys) =
+      case compare x y of
+         LT -> x : rec xs ly
+         EQ -> x : rec xs ys
+         GT -> y : rec lx ys
+   rec xs ys = xs ++ ys
+
+mergesD :: [Dimensions] -> Dimensions
+mergesD = foldr1 mergeD
+
+-----------------------------------------------------------------------------
+
+data Tree = Bin [Tree] | Leaf Double# | Two !Tree !Tree | Three !Tree !Tree !Tree
+
+bin :: [Tree] -> Tree
+bin [x, y] = Two x y
+bin [x, y, z] = Three x y z
+bin xs = Bin xs
+
+leaf :: Double -> Tree
+leaf (D# x) = Leaf x
+
+instance Show Tree where
+   show (Leaf a) = show (D# a)
+   show t        = "(" ++ intercalate "," (map show (subtrees t)) ++ ")"
+
+{-# INLINE mapTree #-}
+mapTree :: (Double# -> Double#) -> Tree -> Tree
+mapTree f = rec
+ where
+   rec (Leaf a) = Leaf (f a)
+   rec t        = mapSubtrees rec t
+
+treeToList :: Tree -> [Double]
+treeToList = ($ []) .  rec
+ where
+   rec (Bin ts) = foldr ((.) . rec) id ts
+   rec (Leaf a) = (D# a:)
+   rec (Two x y) = rec x . rec y
+   rec (Three x y z) = rec x . rec y . rec z
+
+{-# INLINE zipTree #-}
+zipTree :: (Double# -> Double# -> Double#) -> Tree -> Tree -> Tree
+zipTree f = rec
+ where
+   rec (Leaf a) (Leaf b) = Leaf (f a b)
+   rec t1 t2 = zipSubtrees rec t1 t2
+
+{-# INLINE subtrees #-}
+subtrees :: Tree -> [Tree]
+subtrees (Bin xs)  = xs
+subtrees (Two x y) = [x, y]
+subtrees (Three x y z) = [x, y, z]
+subtrees _ = error "subtrees"
+
+{-# INLINE subtree #-}
+subtree :: Int -> Tree -> Tree
+subtree i (Bin xs) = xs !! i
+subtree 0 (Two x _) = x
+subtree 1 (Two _ y) = y
+subtree 0 (Three x _ _) = x
+subtree 1 (Three _ y _) = y
+subtree 2 (Three _ _ z) = z
+subtree _ _ = error "subtree"
+
+{-# INLINE mapSubtrees #-}
+mapSubtrees :: (Tree -> Tree) -> Tree -> Tree
+mapSubtrees f (Bin xs)  = Bin (map f xs)
+mapSubtrees f (Two x y) = Two (f x) (f y)
+mapSubtrees f (Three x y z) = Three (f x) (f y) (f z)
+mapSubtrees _ _ = error "mapSubtrees"
+
+{-# INLINE zipSubtrees #-}
+zipSubtrees :: (Tree -> Tree -> Tree) -> Tree -> Tree -> Tree
+zipSubtrees f (Bin xs) (Bin ys) = Bin (zipWith f xs ys)
+zipSubtrees f (Two x1 x2) (Two y1 y2) = Two (f x1 y1) (f x2 y2)
+zipSubtrees f (Three x1 x2 x3) (Three y1 y2 y3) = Three (f x1 y1) (f x2 y2) (f x3 y3)
+zipSubtrees _ _ _ = error "zipSubtrees"
+
+{-# INLINE mergeWith #-}
+mergeWith :: (Double# -> Double# -> Double#) -> Dimensions -> Dimensions -> Tree -> Tree -> Tree
+mergeWith f da db = rec (merges (fromDimensions da) (fromDimensions db))
+ where
+   rec (TakeLeft:ms)  t1 t2 = mapSubtrees (\x -> rec ms x t2) t1
+   rec (TakeRight:ms) t1 t2 = mapSubtrees (\x -> rec ms t1 x) t2
+   rec (Merge:ms)     t1 t2 = zipSubtrees (rec ms) t1 t2
+   rec []             t1 t2 = zipTree f t1 t2
+
+   merges :: [(String, Int)] -> [(String, Int)] -> [Merge]
+   merges [] [] = []
+   merges (_:ds1) [] = TakeLeft  : merges ds1 []
+   merges [] (_:ds2) = TakeRight : merges [] ds2
+   merges l1@(d1:ds1) l2@(d2:ds2) =
+      case compare d1 d2 of
+         LT -> TakeLeft  : merges ds1 l2
+         EQ -> Merge     : merges ds1 ds2
+         GT -> TakeRight : merges l1 ds2
+
+data Merge = TakeLeft | TakeRight | Merge 
+
+set :: String -> Int -> Dimensions -> Tree -> Tree
+set s i = choose [(s, i)]
+
+choose :: [(String, Int)] -> Dimensions -> Tree -> Tree
+choose env d = rec (dropTail choices)
+ where
+   rec [] t = t
+   rec (Nothing:cs) t = mapSubtrees (rec cs) t
+   rec (Just i:cs)  t = rec cs (subtree i t)
+
+   choices = map (\(s, _) -> lookup s env) (fromDimensions d)
+
+   dropTail = reverse . dropWhile isNothing . reverse
+
+setAtLevel :: Int -> Int -> Tree -> Tree
+setAtLevel lev i = rec lev
+ where
+   rec 0 = subtree i
+   rec l = mapSubtrees (rec (l-1))
+
+reorder :: [(String, Int)] -> [(String, Int)] -> Tree -> Tree
+reorder as bs t | as == bs = t
+reorder (p:rest) (o:old) t | p==o = mapSubtrees (reorder rest old) t
+reorder ((s, n):rest) old t = 
+   case findIndex ((== s) . fst) old of
+      Just l  -> bin [ reorder rest (filter ((/= s) . fst) old) $ setAtLevel l i t | i <- [0..n-1] ]
+      Nothing -> error "invalid reordering"
+reorder _ _ _ = error "invalid reordering"
+ src/Bayes/Inference.hs view
@@ -0,0 +1,157 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Inference 
+   ( getFactors, inferNetwork, pruneNetwork, infer, simulate, Query
+   , inferEvidence
+   , trimFor
+   , toEvidence
+   , toNetwork
+   ) where
+
+import Data.List
+import Data.Maybe
+import Bayes.EliminationOrdering
+import Bayes.Evidence
+import Bayes.Factor hiding (size)
+import qualified Bayes.Factor as F
+import Bayes.Network
+import Bayes.NodeTypes
+import Bayes.Probability
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+-- set of query variables
+type Query = S.Set String
+
+-- list of factors, set query variables qs, and elimination variables vs
+posteriors :: Query -> [Factor] -> EliminationOrdering -> M.Map String [Probability]
+posteriors qs list order =
+   case nextVariable order list [] of
+      Nothing -> M.empty
+      Just (v, rest)
+         | v `S.member` qs -> M.insert v ps results
+         | otherwise ->
+              results
+       where
+         ps      = query v list rest
+         results = posteriors (S.delete v qs) (eliminate list v) rest
+
+query :: String -> [Factor] -> EliminationOrdering -> [Probability]
+query q list order = 
+   case nextVariable order list [q] of
+      Nothing -> map fromDouble (values (normalize (mconcat list)))
+      Just (v, rest) -> query q (if q==v then list else eliminate list v) rest
+
+pruneNetwork :: Query -> Network a -> Network a
+pruneNetwork qs nw = filterNodes ((`S.member` keep) . nodeId) nw
+ where
+   keep = collect S.empty (S.toList qs)
+
+   collect acc [] = acc
+   collect acc (x:xs)
+      | x `S.member` acc = collect acc xs
+      | otherwise =
+           case findNode nw x of
+              Just n  -> collect (S.insert x acc) (parentIds n ++ xs)
+              Nothing -> collect acc xs
+
+getFactors :: Network a -> [Factor]
+getFactors nw = 
+   [ nodeToFactor nw n | n <- nodes nw ]
+
+cptFactor :: [Node a] -> [Probability] -> Factor
+cptFactor ns = makeFactor (map (\n -> (nodeId n, size n)) ns) . map toDouble
+
+nodeToFactor :: Network a -> Node a -> Factor
+nodeToFactor nw n = 
+   case definition n of
+      CPT xs -> cptFactor (parents nw n ++ [n]) xs
+      NoisyMax str xs -> mkNoisyOr (nodeId n, size n) ps str xs
+      NoisyAdder dst ws xs -> mkNoisyAdder (nodeId n, size n) ps dst ws xs
+ where
+   ps = map (\x -> (nodeId x, size x)) (parents nw n)
+
+infer :: Network () -> Evidence -> EliminationOrdering -> Query -> M.Map String [Probability]
+infer nw0 ev vs qs0 = posteriors qs list vs `M.union` givens
+ where
+   nw   = pruneNetwork (qs0 `S.union` S.fromList (map fst cs)) nw0
+   qs   = qs0 S.\\ S.fromList (map fst cs)
+   list = map (conditions cs) (getFactors nw ++ virtualFactors ev)
+   
+   givens = M.fromList $ concatMap f $ fromEvidenceTp ev
+    where
+      f (s, Index i) | s `elem` qs0 = 
+         [(s, [ if a == i then 1 else 0 | a <- take n [0..] ])]
+       where
+         n = maybe 0 size (findNode nw s)
+      f _ = []
+   
+   -- 'cs' is the index-map from the evidence
+   cs = indexMap ev
+
+   virtualFactors :: Evidence -> [Factor]
+   virtualFactors = concatMap f . fromEvidenceTp
+    where
+      f (s, Virtual ps) = [virtualFactor s (map snd ps)]
+      f (_, Index _)    = []
+
+
+-- | Fill in the probabilities into a network.
+toNetwork :: Network () -> M.Map String [Probability] -> Network Probability
+toNetwork nw result = mapNodes f nw
+   where
+   f n = let xs = fromMaybe [] $ M.lookup (nodeId n) result
+         in n { states = zipWith (\(s, _) p -> (s, p)) (states n) xs}
+
+-- | Fill in the probabilities into Evidence.
+toEvidence :: Network () -> M.Map String [Probability] -> Evidence
+toEvidence nw = getVirtuals . toNetwork nw
+
+indexMap :: Evidence -> [(String, Int)]
+indexMap = map f . fromEvidenceTp
+ where
+   f (s, Index i)   = (s, i)
+   f (s, Virtual _) = ('#':s, 0)
+
+inferNetwork :: Network () -> Evidence -> EliminationOrdering -> Query -> Network Probability
+inferNetwork nw ev vs q = toNetwork nw $ infer nw ev vs q
+
+inferEvidence :: Network () -> Evidence -> EliminationOrdering -> Query -> Evidence
+inferEvidence nw ev vs q = toEvidence nw $ infer nw ev vs q
+
+simulate :: String -> EliminationOrdering -> [Factor] -> IO ()
+simulate qv eo fs = do 
+   printFactors
+   case nextVariable eo fs [qv] of
+      Nothing -> print (map normalize fs)
+      Just (x, eo') -> do
+         putStrLn $ "   => " ++ x
+         simulate qv eo' (eliminate fs x)
+ where
+   ns = map F.size fs
+   ss = nub $ concatMap vars fs
+   printFactors = do
+      putStrLn $ "total size: " ++ show (sum ns)
+      putStrLn $ "#factors: " ++ show (length ns)
+      putStrLn $ "#vars: " ++ show (length ss)
+      print ns
+
+
+-- | Remove all 'Evidence' that cannot be fed to the given 'Network'.
+trimFor :: Network a -> Evidence -> Evidence
+trimFor nw = filterEvidence (`elem` map nodeId (nodes nw))
+
+getVirtuals :: Network Probability -> Evidence
+getVirtuals nw = mconcat $ map f (nodes nw)
+ where
+   f n = virtual n (map snd (states n))
+ src/Bayes/InterfaceWriter.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.InterfaceWriter (networkInterface) where
+
+import Data.Char
+import Data.List
+import Bayes.Network
+import Bayes.Probability
+import Bayes.SVG
+
+--------------------------------------------------------------------------------
+
+networkInterface :: String -> Layout -> Network a -> String
+networkInterface moduleName l nw = unlines $
+   [ moduleHeader moduleName
+   , networkDecl nw
+   , layoutDecl l
+   ] ++ map (nodeDecl $ name nw) (nodes nw)
+
+moduleHeader :: String -> String
+moduleHeader moduleName = unlines
+   [ "-- generated code: do not change"
+   , "module Task.Network." ++ moduleName ++ " where"
+   , ""
+   , "import Bayes.Network"
+   , "import Bayes.SVG"
+   ]
+
+networkDecl :: Network a -> String
+networkDecl nw = unlines
+   [ "network :: Network ()"
+   , "network = makeNetwork " ++ show (name nw) ++ " [" ++ xs ++ "]"
+   ]
+ where
+   xs = commas (map f (nodes nw))
+   f  = ("node_ " ++) . nodeToName (name nw) . nodeId
+
+layoutDecl :: Layout -> String
+layoutDecl l = unlines
+   [ "layout :: Layout"
+   , "layout = " ++ show l
+   ]
+
+nodeDecl :: String -> Node a -> String
+nodeDecl nwName n@(Node i _ xs ps def) = unlines
+   [ nodeToName nwName i ++ " :: Node " ++ tp
+   , nodeToName nwName i ++ " = Node " ++ unwords args
+   ]
+ where
+   args = [show i, show (label n), ppVals, show ps, "(" ++ showDefinition def ++ ")"]
+   (vals, tp) = valuesAndType xs
+   ppVals = "[" ++ commas (map ppVal vals) ++ "]"
+   ppVal (x, y) = "(" ++ y ++ ", " ++ x ++ ")"
+
+nodeToName :: String -> String -> String
+nodeToName nwName nodeName = (\(y:ys) -> toLower y:ys) $ case nwName `isPrefixOf` nodeName of
+   True -> drop (length nwName + 1) nodeName
+   False -> nodeName
+     
+
+showDefinition :: Definition -> String
+showDefinition (CPT xs) = "CPT " ++ show (map toDouble xs)
+showDefinition (NoisyMax str xs) = "NoisyMax " ++ show str ++ " " ++ show (map toDouble xs)
+showDefinition (NoisyAdder str dubs xs) = "NoisyAdder " ++ show str ++ " " ++ show dubs ++ " " ++ show (map toDouble xs)
+
+
+
+commas :: [String] -> String
+commas = intercalate ","
+
+valuesAndType :: [(String, a)] -> ([(String, String)], String)
+valuesAndType list
+   | xs == ["Correct", "Incorrect"] = bool
+   | xs == ["Yes", "No"] = bool
+   | xs == ["Success", "Failure"] = bool
+   | xs == ["success", "failure"] = bool
+   | xs == ["Correct", "Incorrect", "Not_taken"] = maybool1
+   | xs == ["Incorrect", "Not_taken", "Correct"] = maybool2
+   | otherwise = (zip ss ss, "String")
+ where
+   xs   = map fst list
+   ss   = map show xs
+   bool = (zip ["True", "False"] ss, "Bool")
+   maybool1 = (zip ["Just True", "Just False", "Nothing"] ss, "(Maybe Bool)")
+   maybool2 = (zip ["Just False", "Nothing", "Just True"] ss, "(Maybe Bool)")
+ src/Bayes/Network.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Network 
+   ( Network, makeNetwork, name, nodes, nodeIds, mapNodes, mapNodesM, renameNodes, filterNodes, addNode
+   , Node(..), parents, node, node_, size, sizeId, descendants, ancestors, findNode, findStates
+   , Definition(..)
+   , findNodeFuzzy
+   , state2label
+   , label2state
+   ) where
+
+import Bayes.Probability
+import Control.Arrow
+import Data.List
+import Data.Maybe
+import Data.Semigroup
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Util.String ( normalize )
+
+data Network a = Network 
+   { name    :: String
+   , nodeMap :: M.Map String (Node a)
+   }
+ deriving (Eq, Ord)
+
+instance Show a => Show (Network a) where
+   show nw = unlines $ 
+      (take 60 $ "== " ++ name nw ++ repeat '=') : map show (nodes nw)
+
+instance Semigroup (Network a) where
+   nw1 <> nw2 = Network (name nw1 `makeName` name nw2) (M.unionWith overwriteNode (nodeMap nw1) (nodeMap nw2))
+    where
+      makeName x y 
+         | null x    = y
+         | null y    = x
+         | otherwise = x ++ "/" ++ y
+      -- nodes can only be merged when the second node has no parents (but only priors)
+      overwriteNode n1 n2
+         | null (parentIds n2) = n1
+         | otherwise = error $ "Node " ++ nodeId n1 ++ " cannot be merged (try changing the order)"
+
+instance Monoid (Network a) where
+   mempty  = Network "" M.empty
+   mappend = (<>)
+
+instance Functor Network where
+   fmap f nw = nw { nodeMap = M.map (fmap f) (nodeMap nw) }
+
+makeNetwork :: String -> [Node a] -> Network a
+makeNetwork s ns = Network s (M.fromList [ (nodeId n, n) | n <- ns ])
+
+nodes :: Network a -> [Node a]
+nodes = M.elems . nodeMap
+
+nodeIds :: Network a -> S.Set String
+nodeIds = M.keysSet . nodeMap
+
+mapNodes :: (Node a -> Node b) -> Network a -> Network b
+mapNodes f nw = nw {nodeMap = M.map f (nodeMap nw)}
+
+mapNodesM :: Monad m => (Node a -> m (Node b)) -> Network a -> m (Network b)
+mapNodesM f nw = do
+   let m = nodeMap nw
+   xs <- mapM f (M.elems m)
+   return nw {nodeMap = M.fromList $ zip (M.keys m) xs }
+
+renameNodes :: (String -> String) -> Network a -> Network a
+renameNodes f nw = makeNetwork (name nw) (map (renameNode f) (nodes nw))
+
+filterNodes :: (Node a -> Bool) -> Network a -> Network a
+filterNodes p nw = nw {nodeMap = M.filter p (nodeMap nw)}
+
+addNode :: Node a -> Network a -> Network a
+addNode n nw = nw 
+   { nodeMap = M.insert (nodeId n) n (nodeMap nw) 
+   }
+
+data Definition 
+   = CPT [Probability]            -- conditional probability table (standard)
+   | NoisyMax [Int] [Probability] -- noisy max, with strengths and network parameters
+   | NoisyAdder [Int] [Double] [Probability] -- noisy adder, with distinguished states, weights, and network parameters
+
+data Node a = Node
+   { nodeId     :: String
+   , label      :: String
+   , states     :: [(String, a)]
+   , parentIds  :: [String]
+   , definition :: Definition
+   }
+
+instance Show a => Show (Node a) where
+   show n = unlines $ 
+      nodeId n : map f (states n)
+    where
+      f (s, a) = "  " ++ s ++ ": " ++ show a
+  
+instance Eq (Node a) where
+   n1 == n2 = nodeId n1 == nodeId n2
+   
+instance Ord (Node a) where
+   compare n1 n2 = compare (nodeId n1) (nodeId n2)
+
+instance Functor Node where
+   fmap f n = n { states = map (second f) (states n) }
+
+size :: Node a -> Int
+size = length . states
+   
+sizeId :: Network a -> String -> Int
+sizeId nw s = maybe 0 size (findNode nw s)
+   
+node :: String -> Node a
+node s = Node s s [] [] (CPT [])
+
+node_ :: Node a -> Node ()
+node_ = fmap (const ())
+
+parents :: Network a -> Node a -> [Node a]
+parents nw n = mapMaybe (findNode nw) (parentIds n)
+
+renameNode :: (String -> String) -> Node a -> Node a
+renameNode f n = n
+   { nodeId    = f (nodeId n)
+   , parentIds = map f (parentIds n)
+   }
+
+findNode :: Network a -> String -> Maybe (Node a)
+findNode nw s = M.lookup s (nodeMap nw)
+
+-- | Find a node based on its name, ignoring capitalisation, whitespace and
+-- interpunction, and also ignoring if the network is prefixed with its own name.
+findNodeFuzzy :: Monad m => Network a -> String -> m (Node a)
+findNodeFuzzy nw targetID = maybe (fail err) return . find predicate . M.elems . nodeMap $ nw
+
+   where
+
+   err = "Could find no node resembling " ++ targetID ++ " in the network " ++ name nw
+
+   predicate :: Node a -> Bool
+   predicate n = 
+      let nodeID = nodeId n
+      in  normalize targetID == normalize nodeID || 
+          ((name nw `isPrefixOf` nodeID) && normalize (drop (length (name nw) + 1) nodeID) == normalize targetID)
+
+
+
+-- | Find all states associated with a certain node.
+findStates :: Network a -> String -> [(String, Int)]
+findStates nw 
+   = flip zip [0..] 
+   . map fst
+   . maybe [] states 
+   . findNode nw
+
+
+-- | Transform a state index of a node to its string label.
+state2label :: Network a -> String -> Int -> String
+state2label nw nodeID i
+   = (\xs -> if i < length xs then xs !! i else "unknown state #" ++ show i)
+   . map fst
+   . maybe [] states 
+   $ findNode nw nodeID
+
+-- | Transform a state node label to its state index.
+label2state :: Network a -> String -> String -> Int
+label2state nw nodeLabel stateLabel = maybe (error $ "no such state " ++ stateLabel) id $ lookup stateLabel (findStates nw nodeLabel)
+
+
+ancestors :: Network a -> Node a -> [Node a]
+ancestors nw n = nub $ ps ++ concatMap (ancestors nw) ps
+ where 
+   ps = parents nw n
+
+descendants :: Network a -> Node a -> [Node a]
+descendants nw = rec [] . return
+ where
+   rec acc [] = acc 
+   rec acc (x:xs) =  
+      let ys = filter (elem x . parents nw) (nodes nw)
+      in rec (ys `union` acc) (ys `union` xs)
+ src/Bayes/NetworkReader.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.NetworkReader (readNetwork) where
+
+import Control.Monad
+import Numeric
+import Ideas.Text.XML hiding (name)
+import Ideas.Utils.Prelude
+import Bayes.Network
+import Bayes.Probability
+import Bayes.SVG
+
+readNetwork :: FilePath -> IO (Layout, Network ())
+readNetwork = parseXMLFile >=> xmlToNetwork
+
+data GenieNode = GenieNode
+   { genieNodeId   :: String
+   , genieName     :: String
+   , geniePosition :: Point
+   }
+
+xmlToNetwork :: Monad m => XML -> m (Layout, Network ())
+xmlToNetwork xml = do
+   networkId <- findAttribute "id" xml
+   ns   <- findChild "nodes" xml >>= xmlToNodes
+   exts <- findChild "extensions" xml >>= xmlToExtensions
+   let addLabel n = 
+          case filter ((== nodeId n) . genieNodeId) exts of
+             gn:_ -> n {label = genieName gn}
+             _ -> n
+   return ( map (\gn -> (genieNodeId gn, geniePosition gn)) exts
+          , mapNodes addLabel (makeNetwork networkId ns)
+          )
+
+data NodeType = DefNormal | DefNoisyMax | DefNoisyAdder
+
+xmlToNodes :: Monad m => XML -> m [Node ()]
+xmlToNodes xml = (\xs ys zs -> xs ++ ys ++ zs)
+   <$> mapM (xmlToNode DefNormal)     (findChildren "cpt" xml)
+   <*> mapM (xmlToNode DefNoisyMax)   (findChildren "noisymax" xml)
+   <*> mapM (xmlToNode DefNoisyAdder) (findChildren "noisyadder" xml)
+
+xmlToNode :: Monad m => NodeType -> XML -> m (Node ())
+xmlToNode nodeTp xml = do
+   nId <- findAttribute "id" xml
+   xs  <- mapM xmlToState (findChildren "state" xml)
+   let pars = maybe [] xmlToParents (findChild "parents" xml)
+   def <- case nodeTp of
+             DefNormal -> CPT <$> (findChild "probabilities" xml >>= xmlToProbabilities)
+             DefNoisyMax -> do
+                str <- findChild "strengths"  xml >>= xmlToInts
+                pms <- findChild "parameters" xml >>= xmlToProbabilities
+                return $ NoisyMax str pms
+             DefNoisyAdder -> do
+                dst <- findChild "dstates" xml    >>= xmlToInts
+                ws  <- findChild "weights" xml    >>= xmlToDoubles
+                pms <- findChild "parameters" xml >>= xmlToProbabilities
+                return $ NoisyAdder dst ws pms
+   return $ Node nId "" xs pars def
+
+xmlToState :: Monad m => XML -> m (String, ())
+xmlToState xml = do
+   stateId <- findAttribute "id" xml
+   return (stateId, ())
+
+xmlToParents :: XML -> [String]
+xmlToParents xml = words $ getData xml
+
+xmlToProbabilities :: Monad m => XML -> m [Probability]
+xmlToProbabilities xml =
+   mapM (fmap fromRational . readRational) $ words $ getData xml
+
+xmlToInts :: Monad m => XML -> m [Int]
+xmlToInts = mapM readM . words . getData
+
+xmlToDoubles :: Monad m => XML -> m [Double]
+xmlToDoubles = mapM readM . words . getData
+
+readRational :: Monad m => String -> m Rational
+readRational s = 
+   case readFloat s of 
+      (r, _):_ -> return r
+      _        -> fail $ "readRational " ++ s
+
+xmlToExtensions :: Monad m => XML -> m [GenieNode]
+xmlToExtensions xml =
+   concat <$> mapM xmlToGenie (findChildren "genie" xml)
+
+xmlToGenie :: Monad m => XML -> m [GenieNode]
+xmlToGenie xml =
+   mapM xmlToGenieNode (findChildren "node" xml)
+
+xmlToGenieNode :: Monad m => XML -> m GenieNode
+xmlToGenieNode xml = GenieNode
+   <$> findAttribute "id" xml
+   <*> getData <$> findChild "name" xml
+   <*> (findChild "position" xml >>= xmlToPosition)
+
+xmlToPosition :: Monad m => XML -> m Point
+xmlToPosition xml = f <$> (mapM readM (words (getData xml)))
+ where
+   f [x1, y1, _, _] = pt x1 y1 -- ignore x2 and y2: use fixed width and height
+   f _ = pt 0 0
+ src/Bayes/NodeTypes.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.NodeTypes 
+   ( virtualFactor, mkNoisyOr, mkNoisyAdder, mkNoisyAdder2
+   ) where
+
+import Bayes.Factor
+import Bayes.Probability
+import Data.List
+import Data.Semigroup
+
+virtualFactor :: String -> [Probability] -> Factor
+virtualFactor s ps = makeFactor [(s, length ps), ('#':s, 2)] (concatMap f ps)
+ where
+   f x = map toDouble [x, 1-x]
+
+mkNoisyOr :: (String, Int) -> [(String, Int)] -> [Int] -> [Probability] -> Factor
+mkNoisyOr target vs str cs = sumouts (map f (reverse vs) ++ ["L"]) (mconcat (mkVars target vs str cs ++ [orGate target vs]))
+ where 
+   f (s, _) = 'X':s
+
+mkVars :: (a, Int) -> [(String, Int)] -> [Int] -> [Probability] -> [Factor]
+mkVars target [] _ cs = [makeFactor [("L", snd target)] (map toDouble cs)]
+mkVars target (v:vs) str cs = mkVar v (snd target) (shuffleGroups (snd target) str1 cs1) : mkVars target vs str2 cs2
+ where
+   (cs1, cs2)   = splitAt (snd target * snd v) cs
+   (str1, str2) = splitAt (snd v) str
+
+mkVar :: (String, Int) -> Int -> [Probability] -> Factor
+mkVar (s, n) nx = makeFactor [(s, n), ('X':s, nx)] . map toDouble
+
+orGate :: (String, Int) -> [(String, Int)] -> Factor
+orGate target vs = makeFactor ns cs
+ where
+   ns = map h vs ++ [("L", snd target), target]
+   cs = cartesian g (map minimum (combine (map f (map h vs ++ [target])))) (f target)
+   f (_, n) = take n [0::Int ..]
+   g x y = if x == y then 1 else 0
+   h (s, _) = ('X':s, snd target)
+
+combine :: [[a]] -> [[a]]
+combine = foldr (cartesian (:)) [[]]
+
+cartesian :: (a -> b -> c) -> [a] -> [b] -> [c]
+cartesian f as bs = [ f a b | a <- as, b <- bs ]
+
+shuffleGroups :: Int -> [Int] -> [a] -> [a]
+shuffleGroups n is = concat . shuffle is . groups n
+
+shuffle :: [Int] -> [a] -> [a]
+shuffle is as = map (as !!) is
+
+groups :: Int -> [a] -> [[a]] -- copied from factor
+groups n xs 
+   | null xs   = []
+   | otherwise = xs1 : groups n xs2
+ where
+   (xs1, xs2) = splitAt n xs
+
+--------------------------------------------------------------------------------
+
+mkNoisyAdder :: (String, Int) -> [(String, Int)] -> [Int] -> [Double] -> [Probability] -> Factor
+mkNoisyAdder target vs dst ws params =
+   mkNoisyAdder2 target (sort tups) (last ws, last pss)
+ where
+   -- dimensions for parents
+   (ss, ns) = unzip vs
+   -- parameters for each parent (and lastly, leak)
+   pss = splitParameters ns params
+   -- 5-tuples for each parent (var, dimension, distinguished node, weight, parameters)
+   tups = zip5 ss ns (tail dst) (init ws) (init pss)
+
+   splitParameters :: [Int] -> [Probability] -> [[Probability]]
+   splitParameters [] cs = [cs]
+   splitParameters (y:ys) cs =
+      let (cs1, cs2) = splitAt (y * snd target) cs
+      in cs1 : splitParameters ys cs2
+
+mkNoisyAdder2 :: (String, Int) -> [(String, Int, Int, Double, [Probability])] -> (Double, [Probability]) -> Factor
+mkNoisyAdder2 target@(_, tn) tups (lw, lps) = 
+   makeFactor (vs ++ [target]) $  map fromAvg result
+ where
+   vs     = map (\(s, n, _, _, _) -> (s, n)) tups
+   result = snd (foldr add start tups)
+   start  = (1, zipWith avg lps (replicate tn lw))
+
+   -- keep cumulative sizes for aligning tables in result (first component)
+   add :: (String, Int, Int, Double, [Probability]) -> (Int, [Avg]) -> (Int, [Avg])
+   add (_, n, d, w, fc) (cum, ps) = (cum*n, zipWith (<>) (alignTable cum tn qs) (concat (replicate n ps)))
+    where
+      qs = zipWith avg fc (mkWeights n d w)
+
+   mkWeights :: Int -> Int -> Double -> [Double]
+   mkWeights n d w = [ if x==d then 0 else w | x <- [0..n-1], _ <- [1..tn] ]
+
+alignTable :: Int -> Int -> [a] -> [a]
+alignTable a b xs = concat $ concatMap (replicate a) (groups b xs)
+
+-- weighted average
+data Avg = Avg !Double !Double -- sum of weighted values and sum of weights 
+
+instance Show Avg where
+   show = show . fromAvg
+
+instance Semigroup Avg where
+   Avg a1 w1 <> Avg a2 w2 = Avg (a1+a2) (w1+w2)
+
+instance Monoid Avg where
+   mempty  = Avg 0 0
+   mappend = (<>)
+
+avg :: Probability -> Double -> Avg
+avg x y = Avg (toDouble x*y) y
+
+fromAvg :: Avg -> Double
+fromAvg (Avg x y) = x / y
+ src/Bayes/Probability.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Probability (Probability, toDouble, fromDouble) where
+
+data Probability = P { toDouble :: !Double }
+ deriving (Eq, Ord)
+
+instance Show Probability where
+   show (P a) = display 1 (toRational a*100) ++ "%"
+
+instance Num Probability where
+   P a + P b     = P (a + b)
+   P a - P b     = P (a - b)
+   P a * P b     = P (a * b)
+   abs (P a)     = P (abs a)
+   signum (P a)  = P (signum a)
+   fromInteger n = P (fromInteger n)
+   
+instance Fractional Probability where
+   P a / P b     = P (a / b)
+   fromRational a = P (fromRational a)
+
+instance Real Probability where
+   toRational (P a) = toRational a
+
+fromDouble :: Double -> Probability
+fromDouble = P
+
+display :: Int -> Rational -> String
+display digits r
+   | digits > 0  = show n1 ++ "." ++ leading (show n2)
+   | digits == 0 = show n1
+   | otherwise   = error "display: negative number of digits"
+ where
+   n, n1, n2 :: Integer
+   n        = round (r * (10^digits))
+   (n1, n2) = n `quotRem` (10^digits)
+
+   leading :: String -> String
+   leading s = replicate (digits - length s) '0' ++ s
+ src/Bayes/SVG.hs view
@@ -0,0 +1,176 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.SVG 
+   ( networkToHTML, networkToSVG
+   , Layout, Point, pt, pointX, pointY, Color
+   ) where
+
+import Data.Monoid ( (<>) )
+import Control.Arrow
+import Ideas.Text.HTML hiding (text)
+import Ideas.Text.XML hiding (name, text)
+import Bayes.Network
+import Bayes.Probability
+import Data.Maybe
+import Ideas.Text.HTML.W3CSS (w3css)
+
+type Layout = [(String, Point)]
+
+type Color = String
+
+type Border = (Color, Double)
+
+data Point = Pt { pointX :: Double, pointY :: Double }
+
+data Size = Sz { sizeW :: Double, sizeH :: Double }
+
+instance Show Point where
+   show p = unwords ["pt", show (pointX p), show (pointY p)]
+
+instance Num Point where
+   (+)    = lift2Pt (+)
+   (-)    = lift2Pt (-)
+   (*)    = lift2Pt (*)
+   abs    = liftPt abs
+   signum = liftPt signum
+   fromInteger n = pt (fromInteger n) (fromInteger n)
+   
+instance Fractional Point where
+   (/) = lift2Pt (/)
+   fromRational r = pt (fromRational r) (fromRational r)
+   
+liftPt :: (Double -> Double) -> Point -> Point
+liftPt f (Pt x y) = pt (f x) (f y)
+   
+lift2Pt :: (Double -> Double -> Double) -> Point -> Point -> Point
+lift2Pt f (Pt x1 y1) (Pt x2 y2) = pt (f x1 x2) (f y1 y2)
+
+pt :: Double -> Double -> Point
+pt = Pt
+
+sz :: Double -> Double -> Size
+sz = Sz
+
+getPoint :: Layout -> Node a -> Point
+getPoint l n = fromMaybe 0 $ lookup (nodeId n) l
+
+getCenterPoint :: Layout -> Node a -> Point
+getCenterPoint l n = getPoint l n + pt (sizeW s) (sizeH s) / 2
+ where
+   s = nodeSize n
+
+getPoint2 :: Layout -> Node a -> Point
+getPoint2 l n = getPoint l n + pt (sizeW s) (sizeH s)
+ where
+   s = nodeSize n
+
+nodeSize :: Node a -> Size
+nodeSize n = sz 150 (15 * fromIntegral (size n) + 25)
+
+normalize :: Layout -> Network a -> (Layout, Size)
+normalize l nw = (map (second trans) l, sz (2*margin+x2-x1) (2*margin+y2-y1))
+ where
+   ps = map snd l ++ map (getPoint2 l) (nodes nw)
+   (x1, x2) = minMax 0 $ map pointX ps
+   (y1, y2) = minMax 0 $ map pointY ps
+   
+   trans p = p - pt x1 y1 + pt margin margin   
+   margin = 5
+
+minMax :: Ord a => a -> [a] -> (a, a)
+minMax a xs = if null xs then (a, a) else (minimum xs, maximum xs)
+
+----------------------------------------------------------------------------
+
+type SVG = XMLBuilder
+
+networkToHTML :: (a -> Maybe Probability) -> Layout -> Network a -> HTMLPage
+networkToHTML f l nw = 
+   w3css $ htmlPage (name nw) (networkToSVG f l nw)
+
+networkToSVG :: (a -> Maybe Probability) -> Layout -> Network a -> SVG
+networkToSVG f l0 nw = element "svg" $
+   [ "width"  .=. show (sizeW s)
+   , "height" .=. show (sizeH s)
+   ] ++
+   map (uncurry (arrowToSVG l)) (arrows nw) ++
+   map (nodeToSVG f l) (nodes nw)
+ where
+   (l, s) = normalize l0 nw
+
+arrows :: Network a -> [(Node a, Node a)]
+arrows nw = [ (b, a) | a <- nodes nw, b <- parents nw a ]
+
+arrowToSVG :: Layout -> Node a -> Node a -> SVG
+arrowToSVG l n1 n2 = line (getCenterPoint l n1) (getCenterPoint l n2)
+
+nodeToSVG :: (a -> Maybe Probability) -> Layout -> Node a -> SVG
+nodeToSVG f l n = 
+   rect p (nodeSize n) "#E5F6F7" (Just ("#196498", 0.8)) (Just (label n))<>
+   text (p + pt 5 14) "#034471" (nodeId n)
+   <> mconcat 
+   [ stateToSVG p (nodeSize n) i s (f a)
+   | (i, (s, a)) <- zip [0..] (states n)
+   ]
+ where
+   p = getPoint l n
+   
+stateToSVG :: Point -> Size -> Int -> String -> Maybe Probability -> SVG
+stateToSVG p s i nId Nothing =
+   text (p + pt 5 (34 + fromIntegral i*15)) "#034471" nId
+stateToSVG p s i nId (Just prob) =
+   rect (p + pt  (5 + sizeW s / 2) (25 + fromIntegral i*15)) barSz (barColors !! i) Nothing Nothing
+   <>
+   text (p + pt 5 (34 + fromIntegral i*15)) "#034471" txt
+ where
+   txt   = nId ++ " " ++ show prob
+   barSz = sz (((sizeW s / 2 - 10) * fromRational (toRational prob))) 10
+ 
+barColors :: [Color]
+barColors = cycle ["#0000C0", "#FF8C00", "#00C000"]
+
+----------------------------------------------------------------------------
+
+text :: Point -> Color -> String -> SVG
+text p c s = element "text"
+   [ "x" .=. show (pointX p)
+   , "y" .=. show (pointY p)
+   , "fill" .=. c
+   , string s
+   , "font-size" .=. "12"
+   ]
+   
+-- filled rectangle
+rect :: Point -> Size -> Color -> Maybe Border -> Maybe String -> SVG
+rect p s c mb mtip = element "rect" $
+   [ "x" .=. show (pointX p)
+   , "y" .=. show (pointY p)
+   , "width"  .=. show (sizeW s)
+   , "height" .=. show (sizeH s)
+   , "fill"   .=. c
+   ] ++ concat
+   [ ["stroke" .=. bc, "stroke-width" .=. show bw]
+   | (bc, bw) <- maybeToList mb
+   ] ++ 
+   [ element "title" [string tip]
+   | tip <- maybeToList mtip
+   ]
+
+line :: Point -> Point -> SVG
+line p1 p2 = element "line"
+   [ "x1"    .=. show (pointX p1)
+   , "y1"    .=. show (pointY p1)
+   , "x2"    .=. show (pointX p2)
+   , "y2"    .=. show (pointY p2)
+   , "style" .=. "stroke:rgb(200,200,200);stroke-width:1"
+   ]
+ src/Bayes/Script.hs view
@@ -0,0 +1,136 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Bayes.Script
+   ( taskConcepts
+   , emptyConcepts
+   , aggregateConcepts
+   , aggregateConcepts'
+   , findEvidence
+   , addModelToLatestRequest
+   ) where
+
+import Bayes.Evidence
+import Bayes.EliminationOrdering ( minFactorOrder )
+import Bayes.Inference ( infer, toEvidence )
+import Bayes.Network
+import Data.List hiding (insert)
+import Data.Maybe
+import Data.Function ( on )
+import Control.Monad ( (>=>) )
+import Database.HDBC
+import Database.HDBC.Sqlite3
+import Ideas.Common.Id ( showId )
+import qualified Ideas.Text.XML as XML ( fromXML, XML, parseXML, findChild )
+--import qualified Ideas.Text.XML.Interface as XML
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import qualified Task.Network.StudentModel as StudentModel
+import Recognize.Data.MathStoryProblem (Task(Task), singleNetwork)
+import Bayes.Probability
+import Database.Data
+import Main.Tasks ( tasks, findTaskFuzzy )
+
+
+-- | Add information from the student modeller to the database, based on the
+-- raw input and output of the domain reasoner. This is unfortunately done in a
+-- roundabout way, due to the way the framework functions.
+--
+-- We assume that the latest row to the requests table is the one we're dealing
+-- with, since we must know the row ID to continue.
+addModelToLatestRequest :: Connection -> IO ()
+addModelToLatestRequest conn = do
+   r <- fromMaybe (error "No request to add model to.") <$> latestRecord conn
+   let xmlInput = either (error "Could not read XML") id . XML.parseXML $ r ! "input"
+       (sID, tID) = fromMaybe mempty . collectIDs $ xmlInput
+       inputIDs = intercalate "," . map fst . fromMaybe mempty . collectInputs $ xmlInput
+       reqnr = r ! "rowid" :: Int
+   ev <- findEvidence $ r ! "output"
+   let partialModel = taskConcepts tID ev
+   partialModels <- latestPartialModels conn sID
+   let studentModel = aggregateConcepts $ (tID, partialModel) : partialModels
+   insertRecord conn studentsTable
+       ( insert "studentid" sID
+       . insert "taskid" tID
+       . insert "inputs" inputIDs
+       . insert "requestnr" reqnr
+       . insert "evidence" ev
+       . insert "studentmodel" studentModel
+       . insert "partialmodel" partialModel
+       $ mempty )
+   commit conn
+
+-- Find evidence from a reply of the domain reasoner.
+findEvidence :: Monad m => XML.XML -> m Evidence
+findEvidence = XML.findChild "diagnosis" >=> XML.findChild "evidence" >=> XML.fromXML
+
+
+-- | Run the evidence on the Bayesian networks to add soft evidence.
+--
+-- Instead of running it on the combined model, we run it through the models
+-- seperately and only output the evidence as it should be in the student model
+-- nodes. This should work since there should be no feedback effects at that
+-- point.
+--feed :: Evidence -> StudentModel
+--feed = toEvidence StudentModel.network . feed'
+
+
+-- | Obtain task concept node probabilities for a particular task.
+taskConcepts :: TaskID -> Evidence -> Evidence
+taskConcepts tID ev = 
+   let nw = maybe (error $ "no such task " ++ tID) (\(Task t) -> singleNetwork t) $ findTaskFuzzy tID
+   in  filterEvidence isConcept . toEvidence nw $ infer nw ev minFactorOrder (S.filter isConcept (nodeIds nw))
+
+
+-- | Feeding empty evidence to the task concept evidence. This is used in case
+-- the task is not even mentioned in the precalculations (presumably because no
+-- request for the task was sent).
+emptyConcepts :: [ (TaskID, Evidence) ]
+emptyConcepts = flip map tasks $ \t -> let tID = showId t in (tID, taskConcepts tID mempty)
+
+-- | Same as 'aggregateConcepts', but do not include task concept node
+-- probabilities in final evidence.
+aggregateConcepts' :: [ (TaskID, Evidence) ] -> Evidence
+aggregateConcepts' precalculatedTaskConcepts 
+   = toEvidence StudentModel.network
+   . M.map ((\x->[x,1-x]) . bayesAverage) 
+   . M.fromListWith (++) $
+      [ (concept, [fromDouble . fromRational $ probability])
+      | Task t <- tasks
+      , let taskConcepts' = fromJust . lookup (showId t) $ precalculatedTaskConcepts ++ emptyConcepts
+      , (taskConcept, stateLabel, probability) <- allProbabilities taskConcepts'
+      , stateLabel == "Yes" || stateLabel == "State0" || stateLabel == "Correct" || stateLabel == "Correctr"
+      , concept <- maybeToList . getConcept $ taskConcept
+      ]
+
+
+-- | Aggregate task concept node probabilities into generic concept node
+-- probabilities.
+aggregateConcepts :: [ (TaskID, Evidence) ] -> Evidence
+aggregateConcepts p = aggregateConcepts' p `mappend` mconcat (map snd . nubBy ((==) `on` fst) $ p ++ emptyConcepts)
+
+
+-- for now, just use plain average
+bayesAverage :: [Probability] -> Probability
+bayesAverage ps = sum ps / fromIntegral (length ps)
+
+-- | Task model concept node ID to a student model concept node ID.
+getConcept :: String -> Maybe String
+getConcept ct = 
+   let cs = takeWhile (/= '_') $ ct
+   in if cs `S.member` nodeIds StudentModel.network
+         then Just cs
+         else Nothing
+
+isConcept :: String -> Bool
+isConcept = isJust . getConcept
+ src/Bayes/StudentReport.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Provides reports of the user models.+--+-----------------------------------------------------------------------------++module Bayes.StudentReport where++import Text.Printf (printf)+import Data.Maybe ( listToMaybe )+import Control.Monad ( forM )+import qualified Ideas.Text.XML as XML+import qualified Data.Map as M++import Util.String ( trim )+import Bayes.Evidence (allProbabilities, Evidence)+import Bayes.Network (Network, Node, nodes, parentIds, nodeId, parents, label)+import Bayes.NetworkReader (readNetwork)+++data StudentReport = StudentReport+     { studentID :: String+     , competences :: [Competence]+     }+    +data Translation = Translation+   { translationLabel :: XML.XMLBuilder+   , translationDescription :: Maybe XML.XMLBuilder+   , translationExample :: Maybe XML.XMLBuilder+   }++data Competence = Competence+     { skillID :: String+     , skillText :: Translation+     , skillValue :: Maybe Double+     , subskills :: [Competence]+     }+++-- | Limit nested competences to n levels.+limitNesting :: Int -> StudentReport -> StudentReport+limitNesting n report = report { competences = map (limit n) $ competences report}+   where+   limit :: Int -> Competence -> Competence+   limit 0 c = c { subskills =  [] }+   limit i c = c { subskills = map (limit (i-1)) $ subskills c }  +++buildStudentReport :: M.Map String Translation -> String -> Network () -> Evidence -> StudentReport+buildStudentReport dictionary sID nw sm = StudentReport+   { studentID = sID+   , competences = map makeCompetence roots+   }++   where++   makeCompetence :: Node () -> Competence+   makeCompetence node = Competence +      { skillID = nodeId node+      , skillText = M.findWithDefault defaultTranslation (nodeId node) dictionary+      , skillValue = listToMaybe +         [ fromRational p :: Double+         | (nodeId', stateLabel, p) <- allProbabilities sm+         , nodeId node == nodeId'+         , stateLabel == "Yes"+         ]+      , subskills = map makeCompetence $ children node+      }+   +      where+      defaultTranslation = Translation+         { translationLabel = XML.string $ label node+         , translationDescription = mempty+         , translationExample = mempty+         }++   -- Top-level nodes have no parents+   roots :: [Node ()]+   roots = filter (null . parents nw) +         $ nodes nw++   -- Each successive level is a child of one of the previous levels+   children :: Node () -> [Node ()]+   children node = filter ((nodeId node `elem`) . parentIds) +                  $ nodes nw+++++-- | Get a mapping from NodeIDs to labels and descriptions in the requested+-- language.+getTranslations :: String -> IO (M.Map String Translation) +getTranslations requestedLanguage = do+   xml <- XML.parseXMLFile "networks/labels.xml"+   fmap M.fromList . forM (XML.findChildren "node" xml) $ \nodeXml -> do+      nodeID <- XML.findAttribute "id" nodeXml+      title <- XML.findChild "title" nodeXml >>= getDataLang+      description <- maybe (return Nothing) (return . getDataLang) $ XML.findChild "description" nodeXml+      example <- maybe (return Nothing) (return . getDataLang) $ XML.findChild "example" nodeXml+      return (nodeID, Translation { translationLabel = title, translationDescription = description, translationExample = example })++   where+   getDataLang :: Monad m => XML.XML -> m XML.XMLBuilder+   getDataLang = +      maybe (fail $ "No such language " ++ requestedLanguage) return +         . listToMaybe +         . map (mconcat . map (either (XML.string . trim) XML.builder) . XML.content )+         . filter (\lang -> XML.findAttribute "id" lang == Just requestedLanguage) +         . XML.findChildren "lang"+++-- | Create a student report from a student model.+toReport :: String -> String -> Evidence -> IO StudentReport+toReport sID lang sm = do+   nw <- snd <$> readNetwork "networks/StudentModel.xdsl"+   dictionary <- getTranslations lang+   return . limitNesting 2 $ buildStudentReport dictionary sID nw sm+++instance XML.ToXML Competence where+   toXML c = XML.makeXML "competence" . mconcat $+      [ "id"    XML..=. skillID c+      , "value" XML..=. (maybe "0.5" (printf "%.3f") . skillValue $ c)+      , mconcat $ +         XML.tag "title" (translationLabel text')+         : (maybe mempty (XML.tag "description") (translationDescription text'))+         : (maybe mempty (XML.tag "example") (translationExample text'))+         : map XML.builderXML (subskills c)+      ]++      where +      text' = skillText c++instance XML.ToXML StudentReport where+   toXML report = XML.makeXML "user" $  mconcat +      [ "id" XML..=. studentID report+      , mconcat $ map XML.builderXML (competences report)+      ]
+ src/Database/Data.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Access to the request database.+-- This module provides transparent access to the information stored in the+-- database, and ensures that it is read in a sensible way.+--+-----------------------------------------------------------------------------++module Database.Data+   ( SqlRecord+   , SqlTable(..)+   , requestsTable+   , studentsTable+   , (!)+   , findWithDefault+   , insert+   , adjust+   , quickQueryMap+   , tableExists+   , createTable+   , dropTable+   , insertRecord+   , insertRecords+   , SQL.commit+   , PilotID+   , StudentID+   , TaskID+   , NodeID+   , InputID+   , StudentModel+   , collectSource+   , collectInputs+   , collectIDs+   , collectSolution+   , defaultEntry+   , recordN+   , allEvidence+   , allEvidenceStudents+   , allPartialModels+   , allStudentModels+   , allHumanAssessments+   , tasksDone+   , latestRecord+   , latestEvidence+   , latestPartialModels+   , latestStudentModel+   , latestStudentReport+   , latestInsertRowID+   , records2table+   , allRecords+   , finalRecords+   , taskRecords+   , studentRecords+   , countStudents+   , countEntries +   , countStudentEntries+   , countTaskEntries ) where++import Data.Convertible.Base (Convertible, safeConvert, convError)+import Control.Monad ( when, void, (>=>) )+import Database.HDBC (SqlValue, fromSql, toSql)+import Database.HDBC.Sqlite3 (Connection)+import Ideas.Utils.Prelude (readM)+import qualified Data.Map as M+import qualified Ideas.Text.XML as XML+import qualified Database.HDBC as SQL++import Util.String (wrap)+import Bayes.Evidence ( Evidence )+import Bayes.StudentReport (StudentReport, toReport)+import Recognize.Data.Solution ( Solution )++-------------------------------------------------------------------------------+-- * Data conversion+++instance Convertible SqlValue XML.XML where+   safeConvert sql = either (flip convError sql) Right . XML.parseXML . fromSql $ sql++instance Convertible XML.XML SqlValue where+   safeConvert xml = Right . toSql . XML.compactXML $ xml++instance Convertible SqlValue Evidence where+   safeConvert = Right . maybe mempty id . readM . fromSql++instance Convertible Evidence SqlValue where+   safeConvert = Right . toSql . show ++-- | Extract the source from an XML request element.+collectSource :: Monad m => XML.XML -> m String+collectSource xml = XML.findAttribute "source" xml++-- | Extract the input elements from an XML request element.+collectInputs :: Monad m => XML.XML -> m [(InputID, XML.XML)]+collectInputs xml = do+   inputXMLs <- XML.findChildren "input" <$> XML.findChild "solution" xml+   inputIDs <- mapM (XML.findAttribute "id") inputXMLs+   return $ zip inputIDs inputXMLs+++-- | Extract the student and task ID from an XML request element.+collectIDs :: Monad m => XML.XML -> m (StudentID, TaskID)+collectIDs xml = do+   taskID' <- XML.findAttribute "exerciseid" xml+   studentID' <- XML.findChild "solution" xml >>= XML.findAttribute "userid"+   return (studentID', taskID')+++collectSolution :: Monad m => XML.XML -> m Solution+collectSolution = XML.findChild "solution" >=> XML.fromXML++-------------------------------------------------------------------------------+-- * Generic SQL++-- | SQL records are read into a map.+type SqlRecord = M.Map String SqlValue++-- | An 'SqlTable' collects information that will be useful in constructing SQL+-- statements.+data SqlTable = SqlTable+   { tableName :: String+   , columns :: [(String, String)]+   }+++-- | Obtain the value of a record at a certain column. Differs from `M.!` in+-- that the value will be converted from an 'SqlValue'.+(!) :: Convertible SqlValue a => SqlRecord -> String -> a+record ! key = fromSql $ record M.! key++-- | Obtain the value of a record at a certain column, with a given default.+-- Differs from `M.findWithDefault` in that the value will be converted from an+-- 'SqlValue'.+findWithDefault :: Convertible SqlValue a => a -> String -> SqlRecord -> a+findWithDefault def key = maybe def fromSql . M.lookup key+++-- | Insert a value of a record into a certain column.+insert :: Convertible a SqlValue => String -> a -> SqlRecord -> SqlRecord+insert key value record = M.insert key (toSql value) record+++-- | Update the value of a record at a certain column.+adjust :: (Convertible SqlValue a, Convertible b SqlValue) +       => String -> (a -> b) -> SqlRecord -> SqlRecord+adjust key f record = M.adjust (toSql . f . fromSql) key record+++-- | Like 'Database.HDBC.quickQuery', but obtains 'SqlRecords' instead of lists.+quickQueryMap :: Connection -> String -> [SqlValue] -> IO [SqlRecord]+quickQueryMap conn statement values = do+   stm <- SQL.prepare conn statement+   void $ SQL.execute stm values+   SQL.fetchAllRowsMap stm+++-- | Obtain latest row insertion ID of a particular table.+latestInsertRowID :: Connection -> String -> IO (Maybe Int)+latestInsertRowID conn table = do+   stm <- SQL.prepare conn $ "SELECT last_insert_rowid() FROM "++ table ++" LIMIT 1"+   void $ SQL.execute stm []+   fmap (fromSql . head) <$> SQL.fetchRow stm+++-- | Test if the given table exists.+tableExists :: Connection -> String -> IO Bool+tableExists conn name = (name `elem`) <$> SQL.getTables conn+++-- | Create the given table if it does not already exist.+createTable :: Connection -> SqlTable -> IO ()+createTable conn table = do+   tables <- SQL.getTables conn+   when (not $ tableName table `elem` tables) $ do+      putStrLn $ "Creating `" ++ tableName table ++ "` table…"+      void $ SQL.run conn statement [] ++   where+   statement = +      "CREATE TABLE " ++ tableName table ++ +      wrap " (" ", " ")" (map (\(x,y) -> "`" ++ x ++ "` " ++ y) $ columns table)+++-- | Drop the given table unless it does not exist.+dropTable :: Connection -> SqlTable -> IO ()+dropTable conn table = do+   tables <- SQL.getTables conn+   when (tableName table `elem` tables) $ do+      putStrLn $ "Dropping `" ++ tableName table ++ "` table…"+      void $ SQL.run conn statement [] ++   where+   statement = "DROP TABLE " ++ tableName table+++-- | Insert the given record into a table. Assumes that the record contains at+-- least all the columns of the table.+insertRecord :: Connection -> SqlTable -> SqlRecord -> IO ()+insertRecord conn table record = do+   --putStrLn $ record ! "input"+   void . SQL.run conn statement . entry2sql $ record++   where+   statement = +      "INSERT INTO " ++ tableName table ++ +      " VALUES " ++ wrap "(" "," ")" (length (columns table) `take` repeat "?")++   entry2sql :: SqlRecord -> [SqlValue]+   entry2sql record = map ((record M.!) . fst) (columns table)+++-- | Insert the given records into a table. Assumes that the record contains at+-- least all the columns of the table.+insertRecords :: Connection -> SqlTable -> [SqlRecord] -> IO ()+insertRecords conn table records = do+   putStrLn $  "Inserting " ++ show (length records) +            ++ " records into `" ++ tableName table ++ "`…"+   mapM_ (insertRecord conn table) records+++-------------------------------------------------------------------------------+-- * Database-specific++-- ** SQL tables++type StudentModel = Evidence+type PilotID = String+type StudentID = String+type TaskID = String+type InputID = String+type NodeID = String++requestsTable :: SqlTable+requestsTable = SqlTable +   { tableName = "requests"+   , columns = +      [ ("service", "TEXT")+      , ("exerciseid", "TEXT")+      , ("source", "TEXT")+      , ("script", "TEXT")+      , ("requestinfo", "TEXT")+      , ("dataformat", "TEXT")+      , ("encoding", "TEXT")+      , ("userid", "TEXT")+      , ("sessionid", "TEXT")+      , ("taskid", "TEXT")+      , ("time", "TIME")+      , ("responsetime", "TIME")+      , ("ipaddress", "TEXT")+      , ("binary", "TEXT")+      , ("version", "TEXT")+      , ("errormsg", "TEXT")+      , ("serviceinfo", "TEXT")+      , ("ruleid", "TEXT")+      , ("input", "TEXT")+      , ("output", "TEXT") +      ]+   }++studentsTable :: SqlTable+studentsTable = SqlTable +   { tableName = "students"+   , columns = +      [ ("original", "TEXT")+      , ("studentid", "TEXT")+      , ("taskid", "TEXT")+      , ("inputs", "TEXT")+      , ("requestnr", "INTEGER")+      , ("evidence", "TEXT")+      , ("partialmodel", "TEXT")+      , ("studentmodel", "TEXT")+      ]+   }+++-- | Make a default entry, where all columns are set to null.+defaultEntry :: [SqlTable] -> SqlRecord+defaultEntry = M.fromList . map (fmap $ const SQL.SqlNull) . (>>= columns)+++-- ** Querying++-- | Obtain all records from the 'requests' table, optionally combined with the+-- 'students' table, if the latter is present.+allRecords :: Connection -> IO [SqlRecord]+allRecords conn = do+   tables <- SQL.getTables conn+   if "requests" `elem` tables+      then quickQueryMap conn (stm tables) []+      else error "The `requests` table is not present."++   where+   stm tables = if "students" `elem` tables+      then "SELECT students.ROWID,* FROM requests \+           \INNER JOIN students \+           \ON students.requestnr = requests.ROWID"+      else "SELECT requests.ROWID,* FROM requests"+++-- | Obtain all entries associated with a particular task.+taskRecords :: Connection -> String -> IO [SqlRecord]+taskRecords conn tID = quickQueryMap conn stm [toSql tID]++   where+   stm = "SELECT students.ROWID,* FROM requests \+      \ INNER JOIN students \+      \ ON students.requestnr = requests.ROWID \+      \ WHERE students.taskid=? \+      \ ORDER BY students.ROWID"+++-- | Obtain all entries associated with a particular student.+studentRecords :: Connection -> String -> IO [SqlRecord]+studentRecords conn sID = quickQueryMap conn stm [toSql sID]++   where+   stm = "SELECT students.ROWID,* FROM requests \+      \ INNER JOIN students \+      \ ON students.requestnr = requests.ROWID \+      \ WHERE studentid=? \+      \ ORDER BY students.ROWID"+++-- | Obtain the record at a certain row.+recordN :: Connection -> Int -> IO (Maybe SqlRecord)+recordN conn i = do+   stm' <- SQL.prepare conn stm+   void $ SQL.execute stm' [toSql i]+   SQL.fetchRowMap stm'+   where+   stm = "SELECT requests.ROWID,* FROM requests INNER JOIN students ON students.requestnr=requests.ROWID WHERE requests.ROWID = ?"+++-- | Obtain the final entry for every student.+finalRecords :: Connection -> IO [SqlRecord]+finalRecords conn = quickQueryMap conn stm []++   where+   stm = "SELECT MAX(students.ROWID) as ROWID,* FROM requests \+      \ INNER JOIN students \+      \ ON students.requestnr = requests.ROWID \+      \ GROUP BY students.studentid \+      \ ORDER BY students.ROWID"+++-- | Turn records into a table of evidence.+records2table :: [SqlRecord] -> M.Map (StudentID, TaskID) Evidence+records2table = +   let f r = M.insertWith mappend (r ! "studentid", r ! "taskid") (r ! "evidence")+   in foldl (flip f) mempty+++-- | Get the evidence for every student/task pair.+allEvidence :: Connection -> IO (M.Map (StudentID, TaskID) Evidence)+allEvidence conn = records2table <$> allRecords conn+++-- | Get the evidence for every student.+allEvidenceStudents :: Connection -> IO (M.Map StudentID Evidence)+allEvidenceStudents conn = M.mapKeysWith mappend fst <$> allEvidence conn+++-- | Get the most recent partial models for every task, for every student.+allPartialModels :: Connection -> IO (M.Map StudentID [(TaskID, Evidence)])+allPartialModels conn = do+   records <- quickQueryMap conn stm []+   return . M.fromListWith (++) . map (\r -> (r ! "studentid", [(r!"taskid",r!"partialmodel")])) $ records+   +   where +   stm = "SELECT MAX(ROWID),studentid,taskid,partialmodel FROM students GROUP BY studentid,taskid"+++-- | Get all human assessments, if any exist in the database+allHumanAssessments :: Connection -> IO (M.Map (StudentID, TaskID) [(NodeID, Maybe String, Maybe String)])+allHumanAssessments conn = do+   b <- tableExists conn "assessment"+   if not b+      then return mempty+      else M.fromListWith (++) . map (\[sID, tID, nID, exp', obs] -> ((fromSql sID, fromSql tID), [(fromSql nID, fromSql exp', fromSql obs)])) <$> SQL.quickQuery conn stm []++   where+   stm = "SELECT studentid,taskid,nodeid,expected,observed FROM assessment"+++-- | Get the most recent student model for every student.+allStudentModels :: Connection -> IO [(StudentID, StudentModel)]+allStudentModels conn = +   map (\r -> (r ! "studentid", r ! "studentmodel")) <$> quickQueryMap conn stm []+   +   where +   stm = "SELECT MAX(ROWID),studentid,studentmodel FROM students GROUP BY studentid"+++-- | Get the latest record added to the database.+latestRecord :: Connection -> IO (Maybe SqlRecord)+latestRecord conn = do+   stm <- SQL.prepare conn "SELECT ROWID,* FROM requests ORDER BY rowid DESC LIMIT 1"+   void $ SQL.execute stm []+   SQL.fetchRowMap stm+++-- | Get most recent student model for a particular student.+latestStudentModel :: Connection -> StudentID -> IO StudentModel+latestStudentModel conn sID = do+   stm <- SQL.prepare conn "SELECT studentmodel FROM students \+                           \WHERE studentid = ? ORDER BY requestnr DESC"+   void $ SQL.execute stm [toSql sID]+   maybe mempty (fromSql . head) <$> SQL.fetchRow stm+++-- | Get student report for a particular student.+latestStudentReport :: Connection -> String -> StudentID -> IO StudentReport+latestStudentReport conn lang sID = latestStudentModel conn sID >>= toReport sID lang+++-- | Get all evidence collected for a particular student.+latestEvidence :: Connection -> StudentID -> IO Evidence+latestEvidence conn sID =+   mconcat . map (fromSql . head) <$> SQL.quickQuery conn stm [toSql sID]+   where+   stm = "SELECT evidence FROM students WHERE studentid = ?"+++-- | Get all partial (calculated!) evidence models for a particular student.+latestPartialModels :: Connection -> StudentID -> IO [(TaskID, Evidence)]+latestPartialModels conn sID =+   map (\[_,tID,pm] -> (fromSql tID, fromSql pm)) <$> SQL.quickQuery conn stm [toSql sID]+   where+   stm = "SELECT MAX(ROWID),taskid,partialmodel FROM students WHERE studentid = ? GROUP BY taskid"+++-- | Get all Tasks a student has finished and all Tasks they have yet to+-- finish.+tasksDone :: Connection -> StudentID -> IO [TaskID]+tasksDone conn sID = do+   map (fromSql . head) <$> SQL.quickQuery conn stm [toSql sID]+   where+   stm = "SELECT taskid FROM students WHERE studentid = ? GROUP BY taskid"+++-- | Obtain the number of requests for each student.+countStudentEntries :: Connection -> IO [(String, Int)]+countStudentEntries conn = +   map (\[sID, n] -> (fromSql sID, fromSql n)) <$> SQL.quickQuery conn stm []++   where+   stm = "SELECT studentid,count(*) FROM students GROUP BY studentid"+++-- | Obtain the number of requests for each task.+countTaskEntries :: Connection -> IO [(String, Int)]+countTaskEntries conn = +   map (\[tID, n] -> (fromSql tID, fromSql n)) <$> SQL.quickQuery conn stm []++   where+   stm = "SELECT taskid,count(*) FROM students GROUP BY taskid"+++-- | Obtain the number of entries for each student/task pair. Should be 0 or 1...+countEntries :: Connection -> IO [((String, String), Int)]+countEntries conn = +   SQL.quickQuery conn stm [] >>= +      mapM (\[sID, tID, n] -> return ((fromSql sID, fromSql tID), fromSql n))++   where+   stm = "SELECT studentid,taskid,count(*) FROM students \+         \GROUP BY studentid, taskid"+++-- | Obtain the total number of students.+countStudents :: Connection -> IO Int+countStudents conn = do+   stm' <- SQL.prepare conn stm+   void $ SQL.execute stm' []+   maybe 0 (fromSql . head) <$> SQL.fetchRow stm'++   where+   stm = "SELECT count(*) FROM \+         \   (SELECT count(*) FROM students GROUP BY studentid)"
+ src/Database/HumanAssessment.hs view
@@ -0,0 +1,306 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Access to human assessments of the databases.+-- +-- This module reads spreadsheets containing human assessments of the data we have+-- collected. This will enable us to compare the data, and use human-collected+-- evidence to feed the Bayesian networks.+--+-----------------------------------------------------------------------------++module Database.HumanAssessment+   ( Tally(..)+   , Match(..)+   , prettyMatches+   , summarise+   , summariseTasks+   , score+   , tally+   , tally'+   , getSpreadsheet+   , getEvidence+   , getHumanMachineFiles+   , readEvidence+   ) where++import Data.List ( sortBy )+import Data.Function ( on )+import Data.Maybe ( fromJust, isJust, fromMaybe )+import Data.Char ( isDigit )+import Data.Semigroup ( Semigroup, (<>) )+import Data.Text ( unpack )+import Control.Monad ( forM, when )+import Control.Lens ( (^.) )+import Text.Printf ( printf )+import System.FilePath ( (</>), (<.>), takeBaseName, takeExtension )+import System.Directory ( getDirectoryContents )+import Text.PrettyPrint.Leijen ( pretty, (<+>), (<$$>) )+import qualified Data.ByteString.Lazy as BS+import qualified Data.Map as M+import qualified Codec.Xlsx as XLSX+import qualified Database.HDBC.Sqlite3 as SQL ( connectSqlite3 )+import qualified Text.PrettyPrint.Leijen as PP++import Util.List ( index )+import Util.String ( split, trim, normalize, percentage, (//) )+import Database.Data ( PilotID, StudentID, TaskID, NodeID, allEvidence )+import Bayes.Evidence ( Evidence, hardEvidence, setId )+import Main.Tasks ( findTaskFuzzy, taskNetwork )+import Bayes.Network ( findNodeFuzzy, states, Node, nodeId, state2label, label2state )+import Recognize.Data.MathStoryProblem ( Task(Task), singleNetwork )+++-- | Obtain a list of pilots and associated spreadsheet + database files.+getHumanMachineFiles :: FilePath -> FilePath -> IO [(PilotID, FilePath, FilePath)]+getHumanMachineFiles machineDir humanDir = do+   files <- filter ((== ".xlsx") . takeExtension) <$> getDirectoryContents humanDir+   forM files $ \file -> do+      let pilot = takeBaseName file+      let spreadsheet = humanDir </> pilot <.> "xlsx"+      let database = machineDir </> pilot <.> "db"+      return (pilot, spreadsheet, database)+++-------------------------------------------------------------------------------+-- Tally++-- | Where did a match or mismatch occur?+data Match = Match+   { locStudent :: StudentID+   , locTask :: TaskID+   , locNode :: NodeID+   , expectation :: Maybe String -- ^ Human assessment+   , observation :: Maybe String -- ^ Machine assessment+   }++-- | Group matches together+--groupMatches :: [Match] -> [((StudentID,TaskID), Match)]+--groupMatches = orderBy (locStudent &&& locTask)+++-- | Counter for the number of times we encounter agreements and disagreements+-- between the human and the machine assessment.+data Tally = Tally+   { matchState :: [Match] -- ^ Human & machine assessment match on state+   , matchAbsence :: [Match] -- ^ Neither human nor machine set a state on the node+   , mismatchState :: [Match] -- ^ Human & machine set a state, but not the same+   , expectedPresence :: [Match] -- ^ Machine does not set a state but human does+   , expectedAbsence:: [Match] -- ^ Human does not set a state but machine does+   }++instance Monoid Tally where+   mempty  = Tally [] [] [] [] []+   mappend = (<>)++instance Semigroup Tally where+   x <> y = Tally+      { matchState = matchState x ++ matchState y+      , matchAbsence = matchAbsence x ++ matchAbsence y+      , mismatchState = mismatchState x ++ mismatchState y+      , expectedPresence = expectedPresence x ++ expectedPresence y+      , expectedAbsence = expectedAbsence x ++ expectedAbsence y+      }++instance PP.Pretty Match where+   pretty m = +      PP.fill 35 (pretty $ locNode m) <+>+      PP.fill 10 (pretty $ locStudent m) <+>+      PP.fill 16 (maybe (pretty "empty") (PP.dquotes . pretty) (expectation m)) <+>+      maybe (pretty "empty") (PP.dquotes . pretty) (observation m)+++prettyMatches :: [Match] -> PP.Doc+prettyMatches matches = +   PP.fill 35 (pretty "NODE") <+>+   PP.fill 10 (pretty "STUDENT") <+>+   PP.fill 16 (pretty "HUMAN/EXPECTED") <+>+   pretty "MACHINE/OBSERVED" <$$>+   (PP.vsep . map pretty $ matches)+++instance PP.Pretty Tally where+   pretty t =+         pretty "Match" <+> perc totalMatch totalTally <$$> (PP.indent 4 $+            pretty "States match" <+> perc (length . matchState) totalMatch <$$>+            pretty "Agree on absence" <+> perc (length . matchAbsence) totalMatch+         ) <$$>+         pretty "Mismatch" <+> perc totalMismatch totalTally <$$> (PP.indent 4 $+            pretty "States mismatch" <+> perc (length . mismatchState) totalMismatch <$$>+            pretty "Expected presence" <+> perc (length . expectedPresence) totalMismatch <$$>+            pretty "Expected absence" <+> perc (length . expectedAbsence) totalMismatch+         ) <$$>+         pretty "Severe mismatches:" <+> PP.text (percentage 1 (score (\t' -> length $ mismatchState t' ++ expectedAbsence t') totalTally t))++         where+         perc f g =+            pretty (f t) <+> pretty "of" <+> pretty (g t) <+>+            PP.parens (PP.text $ percentage 1 (score f g t))+++-- | Obtain the total number of times the human agreed with the machine.+totalMatch :: Tally -> Int+totalMatch t = length (matchState t) + length (matchAbsence t)+++-- | Obtain the total number of times the human disagreed with the machine.+totalMismatch :: Tally -> Int+totalMismatch t = length (mismatchState t) + length (expectedAbsence t) + length (expectedPresence t)+++-- | Obtain the total number of observations.+totalTally :: Tally -> Int+totalTally t = totalMatch t + totalMismatch t++-- | Convert tally fields to a corresponding score.+score :: (Tally -> Int) -> (Tally -> Int) -> Tally -> Double+score field1 field2 t = field1 t // field2 t+++-------------------------------------------------------------------------------+-- Tallying the spreadsheet/database combination++type State = Maybe String++getState :: M.Map (StudentID, TaskID) Evidence +         -> StudentID -> TaskID -> NodeID -> State+getState db sID tID nID = +   M.lookup (sID, tID) db >>= lookup nID . hardEvidence >>= return . state2label taskNetwork nID+++-- | Get the string value at a particular row/col.+(!) :: XLSX.CellMap -> (Int,Int) -> Maybe String+cells ! rowcol = trim . toString <$> (M.lookup rowcol cells >>= (^. XLSX.cellValue))++   where+   -- | Obtain string from cell.+   toString :: XLSX.CellValue -> String+   toString (XLSX.CellText t) = unpack t+   toString (XLSX.CellDouble d) = printf "%.f" d+   toString t = error $ "not a text cell: " ++ show t+++-- | Get the canonical node ID, that is, the node as it appears in the actual+-- network interface (including prefix, correct capitalisation, etc).+canonicalNode :: TaskID -> NodeID -> Node ()+canonicalNode tID nID = either error id $ do+   Task t <- findTaskFuzzy tID+   findNodeFuzzy (singleNetwork t) nID+++-- | Obtain task worksheets from a spreadsheet.+getWorksheets :: XLSX.Xlsx -> [(TaskID, XLSX.CellMap)]+getWorksheets spreadsheet = +   [ (tID, cells)+   | (sheetname, worksheet) <- spreadsheet ^. XLSX.xlSheets+   , let cells = worksheet ^. XLSX.wsCells+   , let tID = normalize . unpack $ sheetname +   ]+++-- | Get the node names and their rows in the spreadsheet (excluding strategy+-- nodes).+getNodes :: XLSX.CellMap -> [(NodeID, Int)]+getNodes cells =+   [ (nodeID_noncanonical, row)+   | (row, col) <- M.keys cells+   , row >= 3+   , col == 1+   , let value = cells ! (row,col)+   , isJust value+   , let nodeID_noncanonical = fromJust value+   ]++-- | Get the students and their columns in the spreadsheet.+getStudents :: XLSX.CellMap -> [(StudentID, Int)]+getStudents cells =+   [ (sID, col)+   | (row, col) <- M.keys cells+   , row == 1+   , col >= 3+   , let value = cells ! (row,col) +   , isJust value+   , let sID = fromJust value+   ]+++-- Get canonical node IDs and state labels of all nodes in a worksheet.+getStates :: TaskID -> XLSX.CellMap -> [((StudentID, NodeID), State)]+getStates tID cells =+   [ ((sID, nodeId node), cells ! (row, col))+   | (sID, col) <- getStudents cells+   , (nodeID_noncanonical, row) <- getNodes cells+   , let node = canonicalNode tID nodeID_noncanonical+   ]+++-- | Get expected evidence from a spreadsheet.+getEvidence :: XLSX.Xlsx -> M.Map (StudentID, TaskID) Evidence+getEvidence spreadsheet = M.fromListWith (<>) $+   [ ((sID, tID), maybe mempty (\state -> setId nodeID (label2state taskNetwork nodeID state) mempty) expected )+   | (tID, cells) <- getWorksheets spreadsheet+   , ((sID, nodeID), expected) <- getStates tID cells+   ]+++-- | Get evidence from an Excel file.+readEvidence :: FilePath -> IO (M.Map (StudentID, TaskID) Evidence)+readEvidence path = getEvidence . XLSX.toXlsx <$> BS.readFile path+++getSpreadsheet :: FilePath -> IO XLSX.Xlsx+getSpreadsheet path = XLSX.toXlsx <$> BS.readFile path++tally :: FilePath -> FilePath -> IO (M.Map (TaskID, NodeID) Tally)+tally spreadsheetFile databaseFile = do+   spreadsheet <- getSpreadsheet spreadsheetFile+   allObserved <- SQL.connectSqlite3 databaseFile >>= allEvidence+   tally' spreadsheet allObserved+++-- | Get the tallies for every task/node combination, based on a spreadsheet+-- file with expected, human-assessed values and a database file with observed,+-- IDEAS-assessed values.+tally' :: XLSX.Xlsx -> M.Map (StudentID,TaskID) Evidence -> IO (M.Map (TaskID, NodeID) Tally)+tally' spreadsheet allObserved = do+   return . M.fromListWith (<>) $+      [ (,) (tID, nodeID) $ categorise match+      | (tID, cells) <- getWorksheets spreadsheet+      , ((sID, nodeID), expected) <- getStates tID cells+      , let observed = getState allObserved sID tID nodeID+      , let match = Match { locStudent = sID, locTask = tID, locNode = nodeID, observation = observed, expectation = expected }+      ]++   where++   -- | Compare the expected and observed states of a node.+   categorise :: Match -> Tally+   categorise match = case expectation match of+      Just e -> case observation match of+         Just o -> if e == o then mempty { matchState = [match] } else mempty { mismatchState = [match] }+         Nothing -> mempty { expectedPresence = [match] }+      Nothing -> case observation match of+         Just _ -> mempty { expectedAbsence = [match] }+         Nothing -> mempty { matchAbsence = [match] }+++++-- | Summarise the tallies per task by combining the tallies for each node.+summariseTasks :: M.Map (TaskID, NodeID) Tally -> M.Map TaskID Tally+summariseTasks = M.mapKeysWith (<>) fst+++-- | Combine multiple tallies.+summarise :: Foldable t => t Tally -> Tally+summarise = foldl (<>) mempty+++
+ src/Database/Priors.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Counts occurrences of evidence in the database.+-- This module allows us to count how often nodes are in a particular state.+--+-----------------------------------------------------------------------------++module Database.Priors+   ( calculatePriors+   , Priors(Priors)+   , Prior(Prior)+   ) where++import Data.Function ( on )+import Data.List ( unionBy )+import Data.Semigroup ( Semigroup, (<>) )+import Text.PrettyPrint.Leijen ( pretty, (<+>) )+import qualified Data.Map as M+import qualified Text.PrettyPrint.Leijen as PP++import Recognize.Data.MathStoryProblem ( Task(Task), singleNetwork )+import Main.Tasks ( findTaskFuzzy, taskNetwork )+import Util.Pretty ( prettyMap )+import Database.Data ( StudentID, TaskID, NodeID )+import Bayes.Evidence ( Evidence, hardEvidence )+import Bayes.Network ( nodeId, nodes, state2label )++-------------------------------------------------------------------------------++-- | Associates nodes with their priors.+newtype Priors = Priors (M.Map (TaskID, NodeID) Prior)++instance Semigroup Prior where+   (Prior x) <> (Prior y) = Prior $ M.unionWith (+) x y++instance Monoid Prior where+   mempty  = Prior mempty+   mappend = (<>)++instance PP.Pretty Prior where+   pretty (Prior m) = +      PP.vsep .+      map (\(k,v) -> case k of+         Nothing -> pretty "<No state>:" <+> pretty v+         Just i -> pretty i PP.<> pretty ':' <+> pretty v) .+      M.toList $ m++-- | Associates state indices (or their absence) with a counter.+newtype Prior = Prior (M.Map (Maybe String) Int)++instance Semigroup Priors where+   (Priors x) <> (Priors y) = Priors $ M.unionWith (<>) x y++instance Monoid Priors where+   mempty  = Priors mempty +   mappend = (<>)++instance PP.Pretty Priors where+   pretty (Priors m) = prettyMap $ M.mapKeysWith (<>) snd m+++-- | Calculate the priors, that is: for every node, count how often each state+-- occurs in the observed data.+calculatePriors :: M.Map (StudentID, TaskID) Evidence -> Priors+calculatePriors =+   M.foldr (<>) mempty .  +   M.mapWithKey (\(_, tID) ev -> makePriors tID ev)++   where++   -- | Obtain available nodes for each task.+   taskNodes :: TaskID -> [NodeID]+   taskNodes = maybe [] (map nodeId . nodes . (\(Task t) -> singleNetwork t)) . findTaskFuzzy++   -- | We make the priors by setting the counters for found evidence states to 1, and setting the counters for available nodes without evidence whatsoever to 1 also.+   makePriors :: TaskID -> Evidence -> Priors+   makePriors tID ev = +      let notFound   = map (\x -> (x, Nothing)) $ taskNodes tID+          found      = map (\(x,y) -> (x, Just . state2label taskNetwork x $ y)) (hardEvidence ev)+          nodeStates = unionBy ((==) `on` fst) found notFound+      in foldr (addNodeState tID) mempty nodeStates++   singleton :: Maybe String -> Prior+   singleton state = Prior $ M.singleton state 1++   addNodeState :: TaskID -> (NodeID, Maybe String) -> Priors -> Priors+   addNodeState tID (nodeID, state) (Priors m) = Priors $ M.insertWith (<>) (tID, nodeID) (singleton state) m+
+ src/Domain/LinearAlgebra/Matrix.hs view
@@ -0,0 +1,295 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.LinearAlgebra.Matrix
+   ( Matrix, Row, Column, isRectangular, makeMatrix, identity, mapWithPos
+   , changeEntries, changeEntry, setEntries, setEntry
+   , rows, row, columns, column, dimensions, entry, isEmpty
+   , add, scale, multiply
+   , reduce, forward, backward, inverse, invertible, rank, nullity, eqMatrix
+   , switchRows, scaleRow, addRow
+   , inRowEchelonForm, inRowReducedEchelonForm
+   , nonZero, pivot, isPivotColumn
+   , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular
+   ) where
+
+import Control.Monad
+import Data.List hiding (transpose)
+import Data.Maybe
+import Domain.Math.Simplification
+import Ideas.Common.Rewriting
+import Test.QuickCheck hiding (scale, function)
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Ideas.Text.OpenMath.Dictionary.Linalg2 as OM
+
+-- Invariant: a matrix is always rectangular
+newtype Matrix a = M [[a]]
+   deriving (Eq, Ord, Show)
+
+type Row    a = [a]
+type Column a = [a]
+
+instance Functor Matrix where
+   fmap f (M rs) = M (map (map f) rs)
+
+instance Foldable Matrix where
+   foldMap f (M xss) = foldMap (mconcat . map f) xss
+
+instance Traversable Matrix where
+   sequenceA (M xss) = M <$> sequenceA (map sequenceA xss)
+
+instance IsTerm a => IsTerm (Matrix a) where
+   toTerm =
+      let f = function matrixrowSymbol . map toTerm
+      in function matrixSymbol . map f . rows
+   fromTerm a = do
+      rs  <- isFunction matrixSymbol a
+      xss <- mapM (isFunction matrixrowSymbol) rs
+      yss <- mapM (mapM fromTerm) xss
+      guard (isRectangular yss)
+      return (makeMatrix yss)
+
+instance Arbitrary a => Arbitrary (Matrix a) where
+   arbitrary = do
+      (i, j) <- arbitrary
+      arbSizedMatrix (i `mod` 5, j `mod` 5)
+
+instance CoArbitrary a => CoArbitrary (Matrix a) where
+   coarbitrary = coarbitrary . rows
+
+arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
+arbSizedMatrix (i, j) =
+   do rs <- replicateM i (vector j)
+      return (makeMatrix rs)
+
+matrixSymbol, matrixrowSymbol :: Symbol
+matrixSymbol    = newSymbol OM.matrixSymbol
+matrixrowSymbol = newSymbol OM.matrixrowSymbol
+
+instance Simplify a => Simplify (Matrix a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
+-- Check whether the table is rectangular
+isRectangular :: [[a]] -> Bool
+isRectangular xss =
+   case map length xss of
+      []   -> True
+      n:ns -> all (==n) ns
+
+-- Constructor function that checks whether the table is rectangular
+makeMatrix :: [Row a] -> Matrix a
+makeMatrix rs
+   | null (concat rs) = M []
+   | isRectangular rs = M rs
+   | otherwise        = error "makeMatrix: not rectangular"
+
+identity :: Num a => Int -> Matrix a
+identity n = M $ map f [0..n-1]
+ where f i = replicate i 0 ++ [1] ++ replicate (n-i-1) 0
+
+isEmpty :: Matrix a -> Bool
+isEmpty (M xs) = null xs
+
+rows :: Matrix a -> [Row a]
+rows (M rs) = rs
+
+row :: Int -> Matrix a -> Row a
+row n = (!!n) . rows
+
+columns :: Matrix a -> [Column a]
+columns = rows . transpose
+
+column :: Int -> Matrix a -> Column a
+column n = (!!n) . columns
+
+dimensions :: Matrix a -> (Int, Int)
+dimensions m = (length $ rows m, length $ columns m)
+
+entry :: (Int, Int) -> Matrix a -> a
+entry (i, j) m = row i m !! j
+
+mapWithPos :: ((Int, Int) -> a -> b) -> Matrix a -> Matrix b
+mapWithPos f (M rs) = M $ zipWith g [0..] rs
+ where g y = zipWith (\x -> f (y, x)) [0..]
+
+changeEntries :: M.Map (Int, Int) (a -> a) -> Matrix a -> Matrix a
+changeEntries mp = mapWithPos (\pos -> M.findWithDefault id pos mp)
+
+changeEntry :: (Int, Int) -> (a -> a) -> Matrix a -> Matrix a
+changeEntry pos = changeEntries . M.singleton pos
+
+setEntries :: M.Map (Int, Int) a -> Matrix a -> Matrix a
+setEntries mp = mapWithPos (\pos a -> M.findWithDefault a pos mp)
+
+setEntry :: (Int, Int) -> a -> Matrix a -> Matrix a
+setEntry pos = setEntries . M.singleton pos
+
+-------------------------------------------------------
+
+add :: Num a => Matrix a -> Matrix a -> Matrix a
+add a b
+   | dimensions a == dimensions b =
+        M $ zipWith (zipWith (+)) (rows a) (rows b)
+   | otherwise =
+        error "add: dimensions differ"
+
+scale :: Num a => a -> Matrix a -> Matrix a
+scale a = fmap (*a)
+
+multiply :: Num a => Matrix a -> Matrix a -> Matrix a
+multiply a b
+   | snd (dimensions a) == fst (dimensions b) =
+        M $ map (\r -> map (sum . zipWith (*) r) (columns b)) (rows a)
+   | otherwise =
+        error "multiply: incorrect dimensions"
+
+-------------------------------------------------------
+-- Gaussian Elimination
+
+reduce :: (Eq a,Fractional a) => Matrix a -> Matrix a
+reduce = backward . forward
+
+forward :: (Eq a,Fractional a) => Matrix a -> Matrix a
+forward m
+   | h==0 || w==0 = m
+   | all (==0) col = M $ zipWith (:) (repeat 0) $ rows $ forward $ M $ map tail $ rows m
+   | x == 0 = forward (switchRows 0 (fromJust $ findIndex (/= 0) col) m)
+   | x == 1 = let M (r:rs) = foldr (\k -> addRow k 0 (negate $ entry (k,0) m)) m [1..h-1]
+                  M ts = forward (M rs)
+              in M (r:ts)
+   | otherwise = forward (scaleRow 0 (1/x) m)
+ where
+   (h, w) = dimensions m
+   x      = entry (0,0) m
+   col    = column 0 m
+
+backward :: (Eq a,Fractional a) => Matrix a -> Matrix a
+backward m = foldr f m [1..h-1]
+ where
+   (h, _) = dimensions m
+   f i    = let g j = case findIndex (/=0) (row i m) of
+                         Just k  -> addRow j i (negate (entry (j, k) m))
+                         Nothing -> id
+            in flip (foldr g) [0..i-1]
+
+rank :: (Eq a,Fractional a) => Matrix a -> Int
+rank = length . filter (isJust . pivot) . rows . reduce
+
+nullity :: (Eq a,Fractional a) => Matrix a -> Int
+nullity m = snd (dimensions m) - rank m
+
+inverse :: (Eq a,Fractional a) => Matrix a -> Maybe (Matrix a)
+inverse m
+   | h /= w     = Nothing
+   | rank m < w = Nothing
+   | otherwise  = Just $ M $ map (drop h) $ rows $ reduce $ M $ zipWith (++) (rows m) $ rows $ identity h
+ where
+   (h, w) = dimensions m
+
+invertible :: (Eq a,Fractional a) => Matrix a -> Bool
+invertible = isJust . inverse
+
+eqMatrix :: (Eq a,Fractional a) => Matrix a -> Matrix a -> Bool
+eqMatrix m1 m2 = reduce m1 == reduce m2
+
+-- test = rank $ makeMatrix $ [[0 :: Rational ,1,1,1], [1,2,3,2], [3,1,1,3]]
+
+-- t = inverse $ M [[1,0],[0,3]]
+
+-------------------------------------------------------
+
+transpose :: Matrix a -> Matrix a
+transpose (M rs) = M (L.transpose rs)
+
+-------------------------------------------------------
+
+isSquare :: Matrix a -> Bool
+isSquare m = i==j
+ where (i, j) = dimensions m
+
+identityMatrix :: Num a => Int -> Matrix a
+identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list
+ where list = [0..n-1]
+
+-------------------------------------------------------
+-- Elementary row operations (preserve matrix equivalence)
+
+checkRow :: Int -> Matrix a -> Bool
+checkRow i m = i >= 0 && i < fst (dimensions m)
+
+switchRows :: Int -> Int -> Matrix a -> Matrix a
+switchRows i j m@(M rs)
+   | i == j = m
+   | i >  j = switchRows j i m
+   | checkRow i m && checkRow j m =
+        let (before, r1:rest)  = splitAt i       rs
+            (middle, r2:after) = splitAt (j-i-1) rest
+        in M $ before ++ [r2] ++ middle ++ [r1] ++ after
+   | otherwise =
+        error "switchRows: invalid rows"
+
+scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a
+scaleRow i a m@(M rs)
+   | checkRow i m =
+        let f y = if y==i then map (*a) else id
+        in M $ zipWith f [0..] rs
+   | otherwise =
+        error "scaleRow: invalid row"
+
+addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a
+addRow i j a m@(M rs)
+   | checkRow i m && checkRow j m =
+        let rj  = map (*a) (row j m)
+            f y = if y==i then zipWith (+) rj else id
+        in M $ zipWith f [0..] rs
+   | otherwise =
+        error "addRow: invalid row"
+
+-------------------------------------------------------
+
+isLowerTriangular :: (Eq a,Num a) => Matrix a -> Bool
+isLowerTriangular = and . zipWith check [1..] . rows
+ where check n = all (==0) . drop n
+
+isUpperTriangular :: (Eq a,Num a) => Matrix a -> Bool
+isUpperTriangular = and . zipWith check [0..] . rows
+ where check n = all (==0) . take n
+
+inRowEchelonForm :: (Eq a,Num a) => Matrix a -> Bool
+inRowEchelonForm (M rs) =
+   not (any nonZero (dropWhile nonZero rs)) &&
+   increasing (map (length . takeWhile (==0)) (filter nonZero rs))
+ where
+   increasing (x:ys@(y:_)) = x < y && increasing ys
+   increasing _ = True
+
+nonZero :: (Eq a,Num a) => [a] -> Bool
+nonZero = any (/=0)
+
+-- or row canonical form
+inRowReducedEchelonForm :: (Eq a,Num a) => Matrix a -> Bool
+inRowReducedEchelonForm m@(M rs) =
+   inRowEchelonForm m &&
+   all (==1) (mapMaybe pivot rs) &&
+   all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs)
+
+pivot :: (Eq a,Num a) => Row a -> Maybe a
+pivot r = case dropWhile (==0) r of
+             hd:_ -> Just hd
+             _    -> Nothing
+
+isPivotColumn :: (Eq a,Num a) => Column a -> Bool
+isPivotColumn c =
+   case filter (/=0) c of
+      [1] -> True
+      _   -> False
+ src/Domain/Logic/BuggyRules.hs view
@@ -0,0 +1,311 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Buggy rules in the logic domain, expressing common misconceptions
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.BuggyRules (buggyRules) where
+
+import Domain.Logic.Formula
+import Domain.Logic.Generator (equalLogicA)
+import Domain.Logic.Utils
+import Ideas.Common.Library hiding (ruleList)
+import qualified Ideas.Common.Library as C
+
+-- Collection of all known buggy rules
+buggyRules :: [Rule SLogic]
+buggyRules =
+   [ buggyCommImp, buggyAssImp, buggyIdemImp, buggyIdemEqui
+   , buggyEquivElim1, buggyImplElim2, buggyEquivElim2, buggyEquivElim3
+   , buggyImplElim, buggyImplElim1, buggyDeMorgan1, buggyDeMorgan2, buggyDeMorgan3
+   , buggyDeMorgan4, buggyDeMorgan5, buggyNotOverImpl, buggyParenth1, buggyParenth2
+   , buggyParenth3, buggyAssoc, buggyAbsor
+   , buggyAndSame, buggyAndCompl, buggyOrSame, buggyOrCompl
+   , buggyTrueProp, buggyFalseProp, buggyDistr, buggyDistrNot
+   , buggyInvIdemImp, buggyInvIdemEqui, buggyInvDefImpl, buggyInvDeMorgan3
+   , buggyInvDeMorgan4, buggyInvDistr
+   , buggyInvAndCompl, buggyInvOrCompl, buggyInvTrueProp, buggyInvFalseProp
+   , buggyAbsor2, buggyOrCompl2, buggyAndCompl2, buggyNotImplElim
+   ]
+
+rule :: RuleBuilder f a => String -> f -> Rule a
+rule s = C.rewriteRule (propositionalId # "buggy" # s)
+
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
+ruleList s = C.rewriteRules (propositionalId # "buggy" # s)
+
+-----------------------------------------------------------------------------
+-- Buggy rules
+
+buggyAndSame :: Rule SLogic
+buggyAndSame = buggy $ rule "AndSame" $
+   \x -> x :&&: x  :~>  T
+
+buggyAndCompl :: Rule SLogic
+buggyAndCompl = buggy $ ruleList "AndCompl"
+   [ \x -> x :&&: Not x  :~>  T
+   , \x -> Not x :&&: x  :~>  T
+   , \x -> x :&&: Not x  :~>  x
+   , \x -> Not x :&&: x  :~>  x
+   ]
+   
+buggyAndCompl2 :: Rule SLogic
+buggyAndCompl2 = buggy $ ruleList "AndCompl2"
+   [ \x y -> (x :&&: y) :&&: (Not x :&&: Not y)  :~>  F
+   , \x y -> (Not x :&&: Not y) :&&:  (x :&&: y) :~>  F
+   , \x y -> (x :||: y) :&&: (Not x :||: Not y)  :~>  F
+   , \x y -> (Not x :||: Not y) :&&:  (x :||: y) :~>  F
+   ]
+
+buggyOrSame :: Rule SLogic
+buggyOrSame = buggy $ rule "OrSame" $
+   \x -> x :||: x  :~>  T
+
+buggyOrCompl :: Rule SLogic
+buggyOrCompl = buggy $ ruleList "OrCompl"
+   [ \x -> x :||: Not x  :~>  F
+   , \x -> Not x :||:  x :~>  F
+   , \x -> x :||: Not x  :~>  x
+   , \x -> Not x :||:  x :~>  x
+   ]
+
+buggyOrCompl2 :: Rule SLogic
+buggyOrCompl2 = buggy $ ruleList "OrCompl2"
+   [ \x y -> (x :&&: y) :||: (Not x :&&: Not y)  :~>  T
+   , \x y -> (Not x :&&: Not y) :||:  (x :&&: y) :~>  T
+   , \x y -> (x :||: y) :||: (Not x :||: Not y)  :~>  T
+   , \x y -> (Not x :||: Not y) :||:  (x :||: y) :~>  T
+   ]
+
+buggyTrueProp :: Rule SLogic
+buggyTrueProp = buggy $ ruleList "TrueProp"
+   [ \x -> x :||: T  :~>  x
+   , \x -> T :||: x  :~>  x
+   , \x -> x :&&: T  :~>  T
+   , \x -> T :&&: x  :~>  T
+   ]
+
+buggyFalseProp :: Rule SLogic
+buggyFalseProp = buggy $ ruleList "FalseProp"
+   [ \x -> x :||: F  :~>  F
+   , \x -> F :||: x  :~>  F
+   , \x -> x :&&: F  :~>  x
+   , \x -> F :&&: x  :~>  x
+   ]
+
+buggyCommImp :: Rule SLogic
+buggyCommImp = buggy $ rule "CommImp" $
+   \x y -> x :->: y  :~>  y :->: x --this does not hold: T->T => T->x
+
+buggyAssImp :: Rule SLogic
+buggyAssImp = buggy $ ruleList "AssImp"
+   [ \x y z -> x :->: (y :->: z)  :~>  (x :->: y) :->: z
+   , \x y z -> (x :->: y) :->: z  :~>  x :->: (y :->: z)
+   ]
+
+buggyIdemImp :: Rule SLogic
+buggyIdemImp = buggy $ rule "IdemImp" $
+   \x -> x :->: x  :~>  x
+
+buggyIdemEqui :: Rule SLogic
+buggyIdemEqui = buggy $ rule "IdemEqui" $
+   \x -> x :<->: x  :~>  x
+
+buggyEquivElim1 :: Rule SLogic
+buggyEquivElim1 = buggy $ ruleList "EquivElim1"
+    [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y)
+    , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&:  y)
+    , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y)
+    , \x y -> x :<->: y :~> (x :&&: y) :||: (x :&&: y)
+    , \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :||: Not y)
+    ]
+
+buggyEquivElim2 :: Rule SLogic
+buggyEquivElim2 = buggy $ ruleList "EquivElim2"
+    [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y)
+    , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y)
+    , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y)
+    ]
+
+buggyEquivElim3 :: Rule SLogic
+buggyEquivElim3 = buggy $ rule "EquivElim3"  $
+     \x y -> x :<->: y :~> Not x :||: y
+
+buggyImplElim :: Rule SLogic
+buggyImplElim = buggy $ ruleList "ImplElim"
+   [ \x y -> x :->: y :~> Not (x :||: y)
+   , \x y -> x :->: y :~> (x :||: y)
+   , \x y -> x :->: y :~> Not (x :&&: y)
+   , \x y -> x :->: y :~> (x :||: Not y)
+   ]
+
+buggyImplElim1 :: Rule SLogic
+buggyImplElim1 = buggy $ rule "ImplElim1"  $
+     \x y -> x :->: y :~> Not x :&&: y
+
+buggyImplElim2 :: Rule SLogic
+buggyImplElim2 = buggy $ rule "ImplElim2" $
+     \x y -> x :->: y :~>  (x :&&: y) :||: (Not x :&&: Not y)
+
+buggyDeMorgan1 :: Rule SLogic
+buggyDeMorgan1 = buggy $ ruleList "DeMorgan1"
+    [ \x y -> Not (x :&&: y) :~>  Not x :||: y
+    , \x y -> Not (x :&&: y) :~>  x :||: Not y
+    , \x y -> Not (x :&&: y) :~>  x :||: y
+    , \x y -> Not (x :||: y) :~>  Not x :&&: y
+    , \x y -> Not (x :||: y) :~>  x :&&: Not y
+    , \x y -> Not (x :||: y) :~>  x :&&: y
+    ]
+
+buggyDeMorgan2 :: Rule SLogic
+buggyDeMorgan2 = buggy $ ruleList "DeMorgan2"
+    [ \x y -> Not (x :&&: y) :~>  Not (Not x :||: Not y)
+    , \x y -> Not (x :||: y) :~>  Not (Not x :&&: Not y) --note the firstNot in both formulas!
+    ]
+buggyDeMorgan3 :: Rule SLogic
+buggyDeMorgan3 = buggy $  rule "DeMorgan3" $
+    \x y -> Not (x :&&: y) :~>  Not x :&&: Not y
+
+buggyDeMorgan4 :: Rule SLogic
+buggyDeMorgan4 = buggy $  rule "DeMorgan4" $
+     \x y -> Not (x :||: y) :~>  Not x :||: Not y
+
+buggyDeMorgan5 :: Rule SLogic
+buggyDeMorgan5 = buggy $ ruleList "DeMorgan5"
+    [ \x y z -> Not (Not (x :&&: y) :||: z) :~>  Not (Not x :||: Not y):||: z
+    , \x y z -> Not (Not (x :&&: y) :&&: z) :~>  Not (Not x :||: Not y):&&: z
+    , \x y z -> Not (Not (x :||: y) :||: z) :~>  Not (Not x :&&: Not y):||: z
+    , \x y z -> Not (Not (x :||: y) :&&: z) :~>  Not (Not x :&&: Not y):&&: z
+    ]
+
+buggyNotOverImpl :: Rule SLogic
+buggyNotOverImpl = buggy $ rule "NotOverImpl" $
+    \x y -> Not (x :->: y) :~> Not x :->: Not y
+
+buggyParenth1 :: Rule SLogic
+buggyParenth1 = buggy $ ruleList "Parenth1"
+    [ \x y -> Not (x :&&: y)     :~> Not x :&&: y
+    , \x y -> Not (x :||: y)     :~> Not x :||: y
+    ]
+
+buggyParenth2 :: Rule SLogic
+buggyParenth2 = buggy $ rule "Parenth2" $
+    \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y)
+
+buggyParenth3 :: Rule SLogic
+buggyParenth3 = buggy $ ruleList "Parenth3"
+    [ \x y -> Not (Not x :&&: y)  :~> x :&&: y
+    , \x y -> Not (Not x :||: y)  :~> x :||: y
+    , \x y -> Not (Not x :->: y)  :~> x :->: y
+    , \x y -> Not (Not x :<->: y) :~> x :<->: y
+    ]
+
+buggyAssoc :: Rule SLogic
+buggyAssoc = buggy $ ruleList "Assoc"
+    [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z
+    , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z)
+    , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z)
+    , \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: z
+    ]
+
+buggyAbsor :: Rule SLogic
+buggyAbsor = buggy $ ruleList "Absor"
+    [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y)
+    , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y)
+    , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y)
+    , \x y z -> (x :&&: y) :&&: ((x :||: y) :||: z) :~> (x :&&: y)
+    ]
+
+buggyAbsor2 :: Rule SLogic
+buggyAbsor2 = buggy $ ruleList "Absor2"
+    [ \x y -> x :||: (x :&&: y)  :~>  y
+    , \x y -> x :||: (y :&&: x)  :~>  y
+    , \x y -> (x :&&: y) :||: x  :~>  y
+    , \x y -> (y :&&: x) :||: x  :~>  y
+    , \x y -> x :&&: (x :||: y)  :~>  y
+    , \x y -> x :&&: (y :||: x)  :~>  y
+    , \x y -> (x :||: y) :&&: x  :~>  y
+    , \x y -> (y :||: x) :&&: x  :~>  y
+    ]
+
+buggyDistr :: Rule SLogic
+buggyDistr = buggy $ ruleList "Distr"
+   [ \x y z -> x :&&: (y :||: z)  :~>  (x :&&: y) :&&: (x :&&: z)
+   , \x y z -> (x :||: y) :&&: z  :~>  (x :&&: z) :&&: (y :&&: z)
+   , \x y z -> x :&&: (y :||: z)  :~>  (x :||: y) :&&: (x :||: z)
+   , \x y z -> (x :||: y) :&&: z  :~>  (x :||: z) :&&: (y :||: z)
+   , \x y z -> x :||: (y :&&: z)  :~>  (x :||: y) :||: (x :||: z)
+   , \x y z -> (x :&&: y) :||: z  :~>  (x :||: z) :||: (y :||: z)
+   , \x y z -> x :||: (y :&&: z)  :~>  (x :&&: y) :||: (x :&&: z)
+   , \x y z -> (x :&&: y) :||: z  :~>  (x :&&: z) :||: (y :&&: z)
+   ]
+
+buggyDistrNot :: Rule SLogic
+buggyDistrNot = buggy $ ruleList "DistrNot"
+   [ \x y z -> Not x :&&: (y :||: z)  :~>  (Not x :&&: y) :||: (x :&&: z)
+   , \x y z -> Not x :&&: (y :||: z)  :~>  (x :&&: y) :||: (Not x :&&: z)
+   , \x y z -> (x :||: y) :&&: Not z  :~>  (x :&&: Not z) :||: (y :&&: z)
+   , \x y z -> (x :||: y) :&&: Not z  :~>  (x :&&: z) :||: (y :&&: Not z)
+   , \x y z -> Not x :||: (y :&&: z)  :~>  (Not x :||: y) :&&: (x :||: z)
+   , \x y z -> Not x :||: (y :&&: z)  :~>  (x :||: y) :&&: (Not x :||: z)
+   , \x y z -> (x :&&: y) :||: Not z  :~>  (x :||: Not z) :&&: (y :||: z)
+   , \x y z -> (x :&&: y) :||: Not z  :~>  (x :||: z) :&&: (y :||: Not z)
+   ]
+
+logicInvRule :: String -> Rule SLogic -> Rule SLogic
+logicInvRule s = makeInvRule equalLogicA (propositionalId # "buggy" # s)
+
+buggyInvAndCompl, buggyInvOrCompl, buggyInvTrueProp, buggyInvFalseProp :: Rule SLogic
+buggyInvAndCompl  = logicInvRule "AndCompl.inv" buggyAndCompl
+buggyInvOrCompl   = logicInvRule "OrCompl.inv" buggyOrCompl
+buggyInvTrueProp  = logicInvRule "TrueProp.inv" buggyTrueProp
+buggyInvFalseProp = logicInvRule "FalseProp.inv" buggyFalseProp
+
+buggyInvIdemImp :: Rule SLogic
+buggyInvIdemImp = buggy $ rule "IdemImp.inv" $
+   \x -> x  :~>  x :->: x
+
+buggyInvIdemEqui :: Rule SLogic
+buggyInvIdemEqui = buggy $ rule "IdemEquiv.inv" $
+   \x -> x  :~>  x :<->: x
+
+buggyInvDefImpl :: Rule SLogic
+buggyInvDefImpl = buggy $ ruleList "DefImpl.inv"
+   [\x y -> Not x :&&: y  :~>  x :->: y
+   ,\x y -> x :||: Not y  :~>  x :->: y
+   ,\x y -> x :&&: Not y  :~>  y :->: x
+   ,\x y -> Not x :||: y  :~>  y :->: x
+   ,\x y -> Not (x :||: y)  :~>  x :->: y
+   ]
+
+buggyInvDeMorgan3 :: Rule SLogic
+buggyInvDeMorgan3 = buggy $  rule "DeMorgan3.inv" $
+    \x y -> Not x :&&: Not y :~>  Not (x :&&:  y)
+
+buggyInvDeMorgan4 :: Rule SLogic
+buggyInvDeMorgan4 = buggy $  rule "DeMorgan4.inv" $
+     \x y -> Not x :||: Not y :~>  Not( x :||:  y)
+
+buggyInvDistr :: Rule SLogic
+buggyInvDistr = buggy $ ruleList "Distr.inv"
+   [ \x y z -> (x :&&: y) :&&: (x :&&: z)  :~>  x :&&: (y :||: z)
+   , \x y z -> (x :&&: z) :&&: (y :&&: z)  :~>  (x :||: y) :&&: z
+   , \x y z -> (x :||: y) :&&: (x :||: z)  :~>  x :&&: (y :||: z)
+   , \x y z -> (x :||: z) :&&: (y :||: z)  :~>  (x :||: y) :&&: z
+   , \x y z -> (x :||: y) :||: (x :||: z)  :~>  x :||: (y :&&: z)
+   , \x y z -> (x :||: z) :||: (y :||: z)  :~>  (x :&&: y) :||: z
+   , \x y z -> (x :&&: y) :||: (x :&&: z)  :~>  x :||: (y :&&: z)
+   , \x y z -> (x :&&: z) :||: (y :&&: z)  :~>  (x :&&: y) :||: z
+   ]
+
+buggyNotImplElim :: Rule SLogic
+buggyNotImplElim = buggy $ rule "ImplNotElim"  $
+     \x y -> Not (x :->: y) :~> Not x :||: y
+ src/Domain/Logic/GeneralizedRules.hs view
@@ -0,0 +1,161 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Generalized rules, and inverse rules, for De Morgan and distributivity
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.GeneralizedRules
+   ( generalRuleDeMorganOr, generalRuleDeMorganAnd
+   , generalRuleDistrAnd, generalRuleDistrOr
+   , generalRuleInvDoubleNegAnd, generalRuleInvDoubleNegOr
+   ) where
+
+-- Note: the generalized rules do not take AC-unification into account,
+-- and perhaps they should.
+import Control.Monad
+import Data.Function
+import Data.List
+import Domain.Logic.Formula
+import Domain.Logic.Utils
+import Ideas.Common.Library
+
+-----------------------------------------------------------------------------
+-- Generalized rules
+
+generalRuleDeMorganOr :: Rule SLogic
+generalRuleDeMorganOr =
+   siblingOf groupDeMorgan $ makeListRule "GenDeMorganOr" f
+ where
+   f (Not e) = do
+      xs <- subDisjunctions e
+      guard (length xs > 2)
+      return (ands (map Not xs))
+   f _ = []
+
+generalRuleDeMorganAnd :: Rule SLogic
+generalRuleDeMorganAnd =
+   siblingOf groupDeMorgan $ makeListRule "GenDeMorganAnd" f
+ where
+   f (Not e) = do
+      xs <- subConjunctions e
+      guard (length xs > 2)
+      return (ors (map Not xs))
+   f _ = []
+
+generalRuleDistrAnd :: Rule SLogic
+generalRuleDistrAnd =
+   siblingOf groupDistribution $ makeListRule "GenAndOverOr" f
+ where
+   f p = do -- left distributive
+      (leftCtx, x, y, rightCtx) <- getConjunctionTop4 p 
+      ys <- subDisjunctions y
+      guard (length ys > 2)
+      return (ands (leftCtx ++ [ors (map (x :&&:) ys)] ++ rightCtx))
+    `mplus` do -- right distributive
+      (leftCtx, x, y, rightCtx) <- getConjunctionTop4 p 
+      xs <- subDisjunctions x
+      guard (length xs > 2)
+      return (ands (leftCtx ++ [ors (map (:&&: y) xs)] ++ rightCtx))
+
+generalRuleDistrOr :: Rule SLogic
+generalRuleDistrOr =
+   siblingOf groupDistribution $ makeListRule "GenOrOverAnd" f
+ where
+   f p = do -- left distributive
+      (leftCtx, x, y, rightCtx) <- getDisjunctionTop4 p
+      ys <- subConjunctions y
+      guard (length ys > 2)
+      return (ors (leftCtx ++ [ands (map (x :||:) ys)] ++ rightCtx))
+    `mplus` do -- right distributive
+       (leftCtx, x, y, rightCtx) <- getDisjunctionTop4 p
+       xs <- subConjunctions x
+       guard (length xs > 2)
+       return (ors (leftCtx ++ [ands (map (:||: y) xs)] ++ rightCtx))
+
+generalRuleInvDoubleNegAnd :: Rule SLogic
+generalRuleInvDoubleNegAnd =
+   siblingOf groupDoubleNegation $ makeListRule "GenInvDoubleNegAnd" f
+ where
+   f p = do 
+      (leftCtx, x, rightCtx) <- getConjunctionTop3 p
+      guard (not (null leftCtx && null rightCtx))
+      return (ands (leftCtx ++ [Not (Not x)] ++ rightCtx)) 
+
+generalRuleInvDoubleNegOr :: Rule SLogic
+generalRuleInvDoubleNegOr =
+   siblingOf groupDoubleNegation $ makeListRule "GenInvDoubleNegOr" f
+ where
+   f p = do 
+      (leftCtx, x, rightCtx) <- getDisjunctionTop3 p
+      guard (not (null leftCtx && null rightCtx))
+      return (ors (leftCtx ++ [Not (Not x)] ++ rightCtx)) 
+
+-------------------------------------------------------------------------
+-- Helper functions
+
+getDisjunctionTop3 :: SLogic -> [([SLogic], SLogic, [SLogic])]
+getDisjunctionTop3 = map f . split3Check . disjunctions
+ where
+   f (x, y, z) = (x, ors y, z)
+
+getConjunctionTop3 :: SLogic -> [([SLogic], SLogic, [SLogic])]
+getConjunctionTop3 = map f . split3Check . conjunctions
+ where
+   f (x, y, z) = (x, ands y, z)
+
+getDisjunctionTop4 :: SLogic -> [([SLogic], SLogic, SLogic, [SLogic])]
+getDisjunctionTop4 = map f . split4 . disjunctions
+ where
+   f (x, y, z, u) = (x, ors y, ors z, u)
+
+getConjunctionTop4 :: SLogic -> [([SLogic], SLogic, SLogic, [SLogic])]
+getConjunctionTop4 = map f . split4 . conjunctions
+ where
+   f (x, y, z, u) = (x, ands y, ands z, u)
+   
+split3Check :: [a] -> [([a], [a], [a])]
+split3Check as = 
+   [ (xs, ys1, ys2)
+   | (xs, ys) <- split as
+   , (ys1, ys2) <- split ys
+   , length ys1 > 1 -- additional check
+   ]
+
+split4 :: [a] -> [([a], [a], [a], [a])]
+split4 as = sortBy (compare `on` smallContext)
+   [ (xs1, xs2, ys1, ys2) 
+   | (xs, ys) <- split as
+   , (xs1, xs2) <- split xs
+   , not (null xs2)
+   , (ys1, ys2) <- split ys
+   , not (null ys1)
+   ]
+ where
+   -- This order tries to use as many elements as possible as distribuant
+   -- (small/empty left and right contexts are preferable)
+   smallContext (xs, _, _, ys) = length xs + length ys
+
+split :: [a] -> [([a], [a])]
+split xs = map (`splitAt` xs) [0 .. length xs]  
+
+-- All combinations where some disjunctions are grouped, and others are not
+subDisjunctions :: SLogic -> [[SLogic]]
+subDisjunctions = subformulas (:||:) . disjunctions
+
+subConjunctions :: SLogic -> [[SLogic]]
+subConjunctions = subformulas (:&&:) . conjunctions
+
+subformulas :: (a -> a -> a) -> [a] -> [[a]]
+subformulas _  []     = []
+subformulas _  [x]    = [[x]]
+subformulas op (x:xs) = map (x:) yss ++ [ op x y : ys| y:ys <- yss ]
+ where
+   yss = subformulas op xs
+ src/Domain/Logic/Generator.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Generator
+   ( generateLogic, generateLevel, equalLogicA, equalLogicACI
+   , normalizeLogicA
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.Function
+import Data.List
+import Domain.Logic.Formula
+import Ideas.Common.Exercise
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.Uniplate
+import Test.QuickCheck
+
+-------------------------------------------------------------
+-- Code that doesn't belong here
+
+-- | Equality modulo associativity of operators
+equalLogicA :: Eq a => Logic a -> Logic a -> Bool
+equalLogicA = (==) `on` normalizeLogicA
+
+normalizeLogicA :: Logic a -> Logic a
+normalizeLogicA a =
+   case a of
+      _ :&&: _ -> ands (map normalizeLogicA (conjunctions a))
+      _ :||: _ -> ors  (map normalizeLogicA (disjunctions a))
+      _        -> descend normalizeLogicA a
+
+-- | Equality modulo associativity/commutativity/idempotency of operators,
+--   and there units/absorbing elements
+equalLogicACI :: Ord a => Logic a -> Logic a -> Bool
+equalLogicACI p q = rec p == rec q
+ where
+   rec a@(_ :&&: _) =
+      let xs = filter (/=T) $ nub $ sort $ conjunctions a
+      in if F `elem` xs then F else ands (map rec xs)
+   rec a@(_ :||: _) =
+      let xs = filter (/=F) $ nub $ sort $ disjunctions a
+      in if T `elem` xs then T else ors (map rec xs)
+   rec a = descend rec a
+
+-----------------------------------------------------------
+-- Logic generator
+
+generateLogic :: Gen SLogic
+generateLogic = normalGenerator
+
+generateLevel :: Difficulty -> (Gen SLogic, (Int, Int))
+generateLevel dif
+   | dif <= Easy      = (easyGenerator,      (3, 6))
+   | dif >= Difficult = (difficultGenerator, (7, 18))
+   | otherwise        = (normalGenerator,    (4, 12))
+
+-- Use the propositions with 3-6 steps
+easyGenerator :: Gen SLogic
+easyGenerator = do
+   n  <- elements [2, 4] -- , return 8]
+   sizedGen True varGen n
+
+-- Use the propositions with 4-12 steps
+normalGenerator :: Gen SLogic
+normalGenerator = do
+   p0 <- sizedGen False varGen 4
+   p1 <- preventSameVar varList p0
+   return (removePartsInDNF p1)
+
+-- Use the propositions with 7-18 steps
+difficultGenerator :: Gen SLogic
+difficultGenerator = do
+   let vs = ShowString "s" : varList
+   p0 <- sizedGen False (elements vs) 4
+   p1 <- preventSameVar vs p0
+   return (removePartsInDNF p1)
+
+varList :: [ShowString]
+varList = map ShowString ["p", "q", "r"]
+
+varGen :: Gen ShowString
+varGen = elements varList
+
+sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a)
+sizedGen constants gen = go
+ where
+   go n
+      | n > 0 =
+           let rec   = go (n `div` 2)
+               op2 f = liftM2 f rec rec
+           in frequency
+                 [ (2, go 0)
+                 , (2, op2 (:->:))
+                 , (1, op2 (:<->:))
+                 , (3, op2 (:&&:))
+                 , (3, op2 (:||:))
+                 , (3, liftM Not rec)
+                 ]
+      | constants = frequency
+           [(5, liftM Var gen), (1, return T), (1, return F)]
+      | otherwise = liftM Var gen
+
+-----------------------------------------------------------------
+-- Simple tricks for creating for "nice" logic propositions
+
+preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a)
+preventSameVar xs = rec
+ where
+   rec p = case holes p of
+              [(Var a, _), (Var b, update)] | a==b -> do
+                 c <- elements $ filter (/=a) xs
+                 return $ update (Var c)
+              _ -> descendM rec p
+
+removePartsInDNF :: SLogic -> SLogic
+removePartsInDNF = buildOr . filter (not . simple) . disjunctions
+ where
+   buildOr [] = T
+   buildOr xs = foldl1 (:||:) xs
+
+   simple = all f . conjunctions
+    where
+      f (Not p) = null (children p)
+      f p       = null (children p)
+
+-----------------------------------------------------------
+--- QuickCheck generator
+
+instance Arbitrary SLogic where
+   arbitrary = sized (\i -> sizedGen True varGen (i `min` 4))
+
+instance CoArbitrary SLogic where
+   coarbitrary = foldLogic
+      (var, bin 1, bin 2, bin 3, bin 4, un 5, con 6, con 7)
+    where
+      con       = variant :: Int -> Gen a -> Gen a
+      var       = un 0 . coarbitrary . map ord . fromShowString
+      un  n a   = con n . a
+      bin n a b = con n . a . b
+ src/Domain/Logic/InverseRules.hs view
@@ -0,0 +1,204 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.InverseRules
+   ( inverseDeMorganOr, inverseDeMorganAnd
+   , inverseAndOverOr, inverseOrOverAnd
+   , inverseIdempOr, inverseIdempAnd
+   , inverseRules
+   ) where
+
+-- Note: the generalized rules do not take AC-unification into account,
+-- and perhaps they should.
+import Control.Monad
+import Domain.Logic.Formula
+import Domain.Logic.Utils
+import Ideas.Common.Library
+
+-----------------------------------------------------------------------------
+-- Inverse rules
+
+-- generalized (works for multiple terms)
+inverseDeMorganOr :: Rule SLogic
+inverseDeMorganOr = siblingOf groupDeMorgan $
+   makeListRule "InvDeMorganOr" $ \p -> do
+      (leftCtx, xs, rightCtx) <- split3 (conjunctions p)
+      guard (length xs > 1)
+      ys <- mapM isComplementM xs
+      return (ands (leftCtx ++ Not (ors ys) : rightCtx))
+
+-- generalized (works for multiple terms)
+inverseDeMorganAnd :: Rule SLogic
+inverseDeMorganAnd = siblingOf groupDeMorgan $
+   makeListRule "InvDeMorganAnd" $ \p -> do
+      (leftCtx, xs, rightCtx) <- split3 (disjunctions p)
+      guard (length xs > 1)
+      ys <- mapM isComplementM xs
+      return (ors (leftCtx ++ Not (ands ys) : rightCtx))
+
+isComplementM :: Monad m => SLogic -> m SLogic
+isComplementM = maybe (fail "not a complement") return . isComplement
+
+inverseAndOverOr :: Rule SLogic
+inverseAndOverOr = siblingOf groupDistribution $
+   makeSimpleRule "InvAndOverOr" $ \p -> do
+      let xs = disjunctions p
+      guard (length xs > 1)
+      do pairs <- mapM isAndHead xs
+         let (as, ys) = unzip pairs
+         guard (allSame as)
+         return (head as :&&: ors ys)
+       `mplus` do
+         pairs <- mapM isAndLast xs
+         let (ys, as) = unzip pairs
+         guard (allSame as)
+         return (ors ys :&&: head as)
+
+inverseOrOverAnd :: Rule SLogic
+inverseOrOverAnd = siblingOf groupDistribution $
+   makeSimpleRule "InvOrOverAnd" $ \p -> do
+      let xs = conjunctions p
+      guard (length xs > 1)
+      do pairs <- mapM isOrHead xs
+         let (as, ys) = unzip pairs
+         guard (allSame as)
+         return (head as :||: ands ys)
+       `mplus` do
+         pairs <- mapM isOrLast xs
+         let (ys, as) = unzip pairs
+         guard (allSame as)
+         return (ands ys :||: head as)
+
+inverseIdempOr :: Rule SLogic
+inverseIdempOr = siblingOf groupIdempotency $
+   makeListRule "InvIdempOr" $ \p -> do
+      (leftCtx, xs, rightCtx) <- split3 (disjunctions p)
+      return (ors (leftCtx ++ xs ++ xs ++ rightCtx))
+
+inverseIdempAnd :: Rule SLogic
+inverseIdempAnd = siblingOf groupIdempotency $
+   makeListRule "InvIdempAnd" $ \p -> do
+      (leftCtx, xs, rightCtx) <- split3 (conjunctions p)
+      return (ands (leftCtx ++ xs ++ xs ++ rightCtx))
+
+isAndHead, isAndLast, isOrHead, isOrLast :: SLogic -> Maybe (SLogic, SLogic)
+isAndHead = useHead (:&&:) . conjunctions
+isAndLast = useLast (:&&:) . conjunctions
+isOrHead  = useHead (:||:) . disjunctions
+isOrLast  = useLast (:||:) . disjunctions
+
+useHead, useLast :: (a -> a -> a) -> [a] -> Maybe (a, a)
+useHead op (x:xs) | not (null xs) =
+   Just (x, foldr1 op xs)
+useHead _ _ = Nothing
+
+useLast op = fmap (\(x, y) -> (y, x)) . useHead (flip op) . reverse
+
+allSame :: Eq a => [a] -> Bool
+allSame []     = True
+allSame (x:xs) = all (==x) xs
+
+-- see GeneralizedRules (but no check for |ys1| > 1)
+split3 :: [a] -> [([a], [a], [a])]
+split3 as = 
+   [ (xs, ys1, ys2)
+   | (xs, ys) <- split as
+   , (ys1, ys2) <- split ys
+   ]
+   
+-- see GeneralizedRules
+split :: [a] -> [([a], [a])]
+split xs = map (`splitAt` xs) [0 .. length xs]  
+
+-----------------------------------------------------------------------------
+-- More inverse rules
+
+inverseRules :: [Rule SLogic]
+inverseRules =
+   [ invDefImpl, invDefEquiv, invDoubleNeg -- , invIdempOr, invIdempAnd
+   , invTrueAnd, invNotTrue, invFalseOr, invNotFalse
+   -- , invDistrAnd, invDistrOr
+   -- , invAbsorpOr, invAbsorpAnd, invTrueOr, invComplOr, invFalseAnd
+   -- , invComplAnd, invDistrAnd, invDistrOr
+   ]
+
+invDefImpl :: Rule SLogic
+invDefImpl = siblingOf groupImplication $ rewriteRule "DefImpl.inv" $
+   \x y -> Not x :||: y  :~>  x :->: y
+
+invDefEquiv :: Rule SLogic
+invDefEquiv = siblingOf groupEquivalence $ rewriteRule "DefEquiv.inv" $
+   \x y -> (x :&&: y) :||: (Not x :&&: Not y)  :~>  x :<->: y
+
+invDoubleNeg :: Rule SLogic
+invDoubleNeg = siblingOf groupDoubleNegation $ rewriteRule "NotNot.inv" $
+   \x -> x  :~>  Not (Not x)
+
+{-
+invIdempOr :: Rule SLogic
+invIdempOr = siblingOf groupIdempotency $ rewriteRule "IdempOr.inv" $
+   \x -> x  :~>  x :||: x
+
+invIdempAnd :: Rule SLogic
+invIdempAnd = siblingOf groupIdempotency $ rewriteRule "IdempAnd.inv" $
+   \x -> x :~> x :&&: x
+-}
+
+invTrueAnd :: Rule SLogic
+invTrueAnd = siblingOf groupTrueConjunction $ rewriteRules "TrueZeroAnd.inv"
+   [ \x -> x  :~>  T :&&: x
+   , \x -> x  :~>  x :&&: T
+   ]
+
+invNotTrue :: Rule SLogic
+invNotTrue = siblingOf groupNotTrue $ rewriteRule "NotTrue.inv" $
+   F  :~>  Not T
+
+invFalseOr :: Rule SLogic
+invFalseOr = siblingOf groupFalseDisjunction $ rewriteRules "FalseZeroOr.inv"
+   [ \x -> x  :~>  F :||: x
+   , \x -> x  :~>  x :||: F
+   ]
+
+invNotFalse :: Rule SLogic
+invNotFalse = siblingOf groupNotFalse $ rewriteRule "NotFalse.inv" $
+   T  :~> Not F
+
+{-
+invDistrAnd :: Rule SLogic
+invDistrAnd = siblingOf groupDistribution $ rewriteRules "AndOverOr.inv"
+   [ \x y z -> (x :&&: y) :||: (x :&&: z)  :~>  x :&&: (y :||: z)
+   , \x y z -> (x :&&: z) :||: (y :&&: z)  :~>  (x :||: y) :&&: z
+   ]
+
+invDistrOr :: Rule SLogic
+invDistrOr = siblingOf groupDistribution $ rewriteRules "OrOverAnd.inv"
+   [ \x y z -> (x :||: y) :&&: (x :||: z)  :~>  x :||: (y :&&: z)
+   , \x y z -> (x :||: z) :&&: (y :||: z)  :~>  (x :&&: y) :||: z
+   ]
+-}
+
+{- TO DO: fix code below
+proofInvRule :: String -> Rule SLogic -> Rule SLogic
+proofInvRule = makeInvRule equalLogicA
+
+invAbsorpOr, invAbsorpAnd, invTrueOr, invComplOr, invFalseAnd,
+   invComplAnd, invDistrAnd, invDistrOr :: Rule SLogic
+invAbsorpOr  = proofInvRule "AbsorpOr.inv" ruleAbsorpOr
+invAbsorpAnd = proofInvRule "AbsorpAnd.inv" ruleAbsorpAnd
+invTrueOr    = proofInvRule "TrueZeroOr.inv" ruleTrueOr
+invComplOr   = proofInvRule "ComplOr.inv" ruleComplOr
+invFalseAnd  = proofInvRule "FalseZeroAnd.inv" ruleFalseAnd
+invComplAnd  = proofInvRule "ComplAnd.inv" ruleComplAnd
+invDistrAnd  = proofInvRule "AndOverOr.inv" ruleDistrAnd -- see GeneralizedRules
+invDistrOr   = proofInvRule "OrOverAnd.inv" ruleDistrOr  -- see GeneralizedRules
+-}
+ src/Domain/Logic/Parser.hs view
@@ -0,0 +1,236 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Parser
+   ( parseLogic, parseLogicPars, parseLogicUnicodePars, parseLogicProof
+   , parseLogicProofs, parseConsequence, parseStatement
+   , ppLogicPars, ppLogicUnicodePars
+   , associateToRight
+   ) where
+
+import Domain.Logic.Formula
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.Uniplate
+import Ideas.Utils.Parsing
+import qualified Text.ParserCombinators.Parsec.Token as P
+
+-----------------------------------------------------------
+--- Parser
+
+parseLogic :: String -> Either String SLogic
+parseLogic = parseBalanced (parserSLogic False False)
+
+parseLogicUnicode :: String -> Either String SLogic
+parseLogicUnicode = parseBalanced (parserSLogic True False)
+
+parseLogicPars :: String -> Either String SLogic
+parseLogicPars input =
+     either (Left . ambiguousOperators parseLogic input) suspiciousVariable
+   $ parseBalanced (parserSLogic False True) input
+
+parseLogicUnicodePars :: String -> Either String SLogic
+parseLogicUnicodePars input =
+   either (Left . ambiguousOperators parseLogicUnicode input) suspiciousVariable
+   $ parseBalanced (parserSLogic True True) input
+
+parseBalanced :: Parser a -> String -> Either String a
+parseBalanced p input =
+   maybe (parseSimple p input) (Left . show) (balanced [('(', ')')] input)
+
+parseLogicProof :: Bool -> String -> Either String (SLogic, SLogic)
+parseLogicProof unicode input =
+   case balanced [('(',')')] input of
+      Just msg -> Left (show msg)
+      Nothing  -> case splitIs input of
+         Just (lhs, _) ->
+            case balanced [('(',')')] lhs of
+               Just e2 -> Left (show e2)
+               Nothing -> parseLogicProof2 unicode input
+         Nothing -> Left "Expecting =="
+
+splitIs :: String -> Maybe (String, String)
+splitIs = rec []
+ where
+   rec acc ('=':'=':xs) = Just (reverse acc, xs)
+   rec acc (x:xs)       = rec (x:acc) xs
+   rec _   []           = Nothing
+
+parseLogicProof2 :: Bool -> String -> Either String (SLogic, SLogic)
+parseLogicProof2 unicode = parseSimple $ do
+   p <- parserSLogic unicode True
+   reservedOp "=="
+   q <- parserSLogic unicode True
+   return (p, q)
+
+parseLogicProofs :: String -> Either String [(SLogic, SLogic)]
+parseLogicProofs = parseSimple $ commaSep1 $ do
+   let unicode = False
+   p <- parserSLogic unicode True
+   reservedOp "=="
+   q <- parserSLogic unicode True
+   return (p, q)
+
+parseConsequence :: Bool -> String -> Either String ([SLogic], SLogic)
+parseConsequence unicode = parseSimple $ do
+   ps <- commaSep1 (parserSLogic unicode True)
+   reservedOp "=>"
+   q <- parserSLogic unicode True
+   return (ps, q)
+
+parseStatement :: Bool -> String -> Either String ([SLogic], SLogic)
+parseStatement unicode = parseSimple $ do
+   ps <- commaSep (parserSLogic unicode True)
+   reservedOp "|-"
+   q <- parserSLogic unicode True
+   return (ps, q)
+
+-- generalized parser
+parserSLogic :: Bool -> Bool -> Parser SLogic
+parserSLogic unicode extraPars = pLogic
+ where
+   pLogic
+      | extraPars = atom <**> option id composed
+      | otherwise = buildExpressionParser table atom
+
+   composed = choice
+      [ flip (:->:)  <$ reservedOp implSym  <*> atom
+      , flip (:<->:) <$ reservedOp equivSym <*> atom
+      , (\xs x -> ors (x:xs))  <$> many1 (reservedOp disjSym >> atom)
+      , (\xs x -> ands (x:xs)) <$> many1 (reservedOp conjSym >> atom)
+      ]
+
+   atom = choice
+      [ T <$ P.reserved lexer trSym
+      , F <$ P.reserved lexer flSym
+      , Var . ShowString <$> P.identifier lexer
+      , P.parens lexer pLogic
+      , Not <$ reservedOp negSym <*> atom
+      ]
+
+   table =
+      [ [Infix ((:->:)  <$ reservedOp implSym)  AssocRight ]
+      , [Infix ((:&&:)  <$ reservedOp conjSym)  AssocRight ]
+      , [Infix ((:||:)  <$ reservedOp disjSym)  AssocRight ]
+      , [Infix ((:<->:) <$ reservedOp equivSym) AssocRight ]
+      ]
+
+   (implSym, equivSym, conjSym, disjSym, negSym, trSym, flSym)
+      | unicode   = unicodeTuple
+      | otherwise = asciiTuple
+
+lexer :: P.TokenParser a
+lexer = P.makeTokenParser $ emptyDef
+   { reservedNames   = ["T", "F"]
+   , reservedOpNames = ["~", "<->", "->", "||", "/\\", "==", "=>"]
+   , identStart      = lower
+   , identLetter     = lower
+   , opStart         = fail ""
+   , opLetter        = fail ""
+   }
+
+reservedOp :: String -> Parser ()
+reservedOp = P.reservedOp lexer
+
+commaSep :: Parser a -> Parser [a]
+commaSep = P.commaSep lexer
+
+commaSep1 :: Parser a -> Parser [a]
+commaSep1 = P.commaSep1 lexer
+
+-----------------------------------------------------------
+--- Helper-functions for syntax warnings
+
+ambiguousOperators :: (String -> Either a b) -> String -> String -> String
+ambiguousOperators p s err =
+   let msg = "Syntax error: ambiguous use of operators (write parentheses)"
+   in either (const err) (const msg) (p s)
+
+-- Report variables
+suspiciousVariable :: SLogic -> Either String SLogic
+suspiciousVariable r =
+   case filter p (map fromShowString (varsLogic r)) of
+      v:_ -> Left $ "Unexpected variable " ++ v
+                 ++ ". Did you forget an operator?"
+      _   -> Right r
+ where
+   p xs = length xs > 1 && all (`elem` "pqrst") xs
+
+-----------------------------------------------------------
+--- Pretty-Printer
+
+-- | Pretty printer that produces extra parentheses: also see parseLogicPars
+ppLogicPars :: SLogic -> String
+ppLogicPars = ppLogicParsGen asciiTuple
+
+-- | Pretty printer with unicode characters
+ppLogicUnicodePars :: SLogic -> String
+ppLogicUnicodePars = ppLogicParsGen unicodeTuple
+
+ppLogicParsGen :: SymbolTuple -> SLogic -> String
+ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = rec1
+ where
+   rec1 p@(_ :&&: _) = recAnd p
+   rec1 p@(_ :||: _) = recOr p
+   rec1 (p :->: q)   = binop impl (rec2 p) (rec2 q)
+   rec1 (p :<->: q)  = binop equiv (rec2 p) (rec2 q)
+   rec1 p            = rec2 p
+
+   recAnd (p :&&: q) = binop conj (recAnd p) (recAnd q)
+   recAnd p          = rec2 p
+
+   recOr (p :||: q) = binop disj (recOr p) (recOr q)
+   recOr p          = rec2 p
+
+   rec2 (Not p) = neg ++ rec2 p
+   rec2 p       = rec3 p
+
+   -- atoms
+   rec3 (Var x) = fromShowString x
+   rec3 T       = tr
+   rec3 F       = fl
+   rec3 p       = pars (rec1 p)
+
+   binop op x y = unwords [x, op, y]
+   pars s = "(" ++ s ++ ")"
+
+associateToRight :: Logic a -> Logic a
+associateToRight p@(_ :&&: _) = ands (map associateToRight (conjunctions p))
+associateToRight p@(_ :||: _) = ors (map associateToRight (disjunctions p))
+associateToRight p = descend associateToRight p
+
+-----------------------------------------------------------
+--- Ascii symbols
+
+type SymbolTuple = (String, String, String, String, String, String, String)
+
+asciiTuple :: SymbolTuple
+asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F")
+
+implASym, equivASym, andASym, orASym, notASym :: String
+implASym  = "->"
+equivASym = "<->"
+andASym   = "/\\"
+orASym    = "||"
+notASym   = "~"
+
+-----------------------------------------------------------
+--- Unicode symbols
+
+unicodeTuple :: SymbolTuple
+unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F")
+
+implUSym, equivUSym, andUSym, orUSym, notUSym :: String
+implUSym  = "\8594"
+equivUSym = "\8596"
+andUSym   = "\8743"
+orUSym    = "\8744"
+notUSym   = "\172"
+ src/Domain/Logic/Rules.hs view
@@ -0,0 +1,190 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Rewrite rules in the logic domain (including all the rules from the
+-- DWA course)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Rules
+   ( ruleAbsorpAnd, ruleAbsorpOr, ruleDistrAnd, ruleDistrOr
+   , ruleComplAnd, ruleComplOr, ruleDeMorganAnd, ruleDeMorganOr
+   , ruleDefEquiv, ruleDefImpl
+   , ruleFalseAnd, ruleFalseOr, ruleIdempAnd, ruleIdempOr
+   , ruleNotFalse, ruleDoubleNeg, ruleNotTrue
+   , ruleTrueAnd, ruleTrueOr
+   , ruleCommOr, ruleCommAnd, ruleAssocOr, ruleAssocAnd
+   ) where
+
+import Domain.Logic.Formula
+import Domain.Logic.Generator()
+import Domain.Logic.Utils
+import Ideas.Common.Library hiding (ruleList)
+
+rule :: RuleBuilder f a => String -> f -> Rule a
+rule = rewriteRule . (propositionalId #)
+
+ruleFor :: RuleBuilder f a => Id -> String -> f -> Rule a
+ruleFor group s = siblingOf group . rule s
+
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
+ruleList = rewriteRules . (propositionalId #)
+
+ruleListFor :: RuleBuilder f a => Id -> String -> [f] -> Rule a
+ruleListFor group s = siblingOf group . ruleList s
+
+-----------------------------------------------------------------------------
+-- Commutativity
+
+ruleCommOr :: Rule SLogic
+ruleCommOr = ruleFor groupCommutativity "CommOr" $
+   \x y -> x :||: y  :~>  y :||: x
+
+ruleCommAnd :: Rule SLogic
+ruleCommAnd = ruleFor groupCommutativity "CommAnd" $
+   \x y -> x :&&: y  :~>  y :&&: x
+
+-----------------------------------------------------------------------------
+-- Associativity (implicit)
+
+ruleAssocOr :: Rule SLogic
+ruleAssocOr = minor $ ruleFor groupAssociativity "AssocOr" $
+   \x y z -> (x :||: y) :||: z  :~>  x :||: (y :||: z)
+
+ruleAssocAnd :: Rule SLogic
+ruleAssocAnd = minor $ ruleFor groupAssociativity "AssocAnd" $
+   \x y z -> (x :&&: y) :&&: z  :~>  x :&&: (y :&&: z)
+
+-----------------------------------------------------------------------------
+-- Distributivity
+
+ruleDistrAnd :: Rule SLogic
+ruleDistrAnd = ruleListFor groupDistribution "AndOverOr"
+   [ \x y z -> x :&&: (y :||: z)  :~>  (x :&&: y) :||: (x :&&: z)
+   , \x y z -> (x :||: y) :&&: z  :~>  (x :&&: z) :||: (y :&&: z)
+   ]
+
+ruleDistrOr :: Rule SLogic
+ruleDistrOr = ruleListFor groupDistribution "OrOverAnd"
+   [ \x y z -> x :||: (y :&&: z)  :~>  (x :||: y) :&&: (x :||: z)
+   , \x y z -> (x :&&: y) :||: z  :~>  (x :||: z) :&&: (y :||: z)
+   ]
+
+-----------------------------------------------------------------------------
+-- Idempotency
+
+ruleIdempOr :: Rule SLogic
+ruleIdempOr = ruleFor groupIdempotency "IdempOr" $
+   \x -> x :||: x  :~>  x
+
+ruleIdempAnd :: Rule SLogic
+ruleIdempAnd = ruleFor groupIdempotency "IdempAnd" $
+   \x -> x :&&: x  :~>  x
+
+-----------------------------------------------------------------------------
+-- Absorption
+
+ruleAbsorpOr :: Rule SLogic
+ruleAbsorpOr = ruleListFor groupAbsorption "AbsorpOr"
+   [ \x y -> x :||: (x :&&: y)  :~>  x
+   , \x y -> x :||: (y :&&: x)  :~>  x
+   , \x y -> (x :&&: y) :||: x  :~>  x
+   , \x y -> (y :&&: x) :||: x  :~>  x
+   ]
+
+ruleAbsorpAnd :: Rule SLogic
+ruleAbsorpAnd = ruleListFor groupAbsorption "AbsorpAnd"
+   [ \x y -> x :&&: (x :||: y)  :~>  x
+   , \x y -> x :&&: (y :||: x)  :~>  x
+   , \x y -> (x :||: y) :&&: x  :~>  x
+   , \x y -> (y :||: x) :&&: x  :~>  x
+   ]
+
+-----------------------------------------------------------------------------
+-- True-properties
+
+ruleTrueOr :: Rule SLogic
+ruleTrueOr = ruleListFor groupTrueDisjunction "TrueZeroOr"
+   [ \x -> T :||: x  :~>  T
+   , \x -> x :||: T  :~>  T
+   ]
+
+ruleTrueAnd :: Rule SLogic
+ruleTrueAnd = ruleListFor groupTrueConjunction "TrueZeroAnd"
+   [ \x -> T :&&: x  :~>  x
+   , \x -> x :&&: T  :~>  x
+   ]
+
+ruleComplOr :: Rule SLogic
+ruleComplOr = ruleListFor groupTrueComplement "ComplOr"
+   [ \x -> x :||: Not x  :~>  T
+   , \x -> Not x :||: x  :~>  T
+   ]
+
+ruleNotTrue :: Rule SLogic
+ruleNotTrue = ruleFor groupNotTrue "NotTrue" $
+   Not T  :~>  F
+
+-----------------------------------------------------------------------------
+-- False-properties
+
+ruleFalseOr :: Rule SLogic
+ruleFalseOr = ruleListFor groupFalseDisjunction "FalseZeroOr"
+   [ \x -> F :||: x  :~>  x
+   , \x -> x :||: F  :~>  x
+   ]
+
+ruleFalseAnd :: Rule SLogic
+ruleFalseAnd = ruleListFor groupFalseConjunction "FalseZeroAnd"
+   [ \x -> F :&&: x  :~>  F
+   , \x -> x :&&: F  :~>  F
+   ]
+
+ruleComplAnd :: Rule SLogic
+ruleComplAnd = ruleListFor groupFalseComplement "ComplAnd"
+   [ \x -> x :&&: Not x  :~>  F
+   , \x -> Not x :&&: x  :~>  F
+   ]
+
+ruleNotFalse :: Rule SLogic
+ruleNotFalse = ruleFor groupNotFalse "NotFalse" $
+   Not F  :~>  T
+
+-----------------------------------------------------------------------------
+-- Double negation
+
+ruleDoubleNeg :: Rule SLogic
+ruleDoubleNeg = ruleFor groupDoubleNegation "NotNot" $
+   \x -> Not (Not x)  :~>  x
+
+-----------------------------------------------------------------------------
+-- De Morgan
+
+ruleDeMorganOr :: Rule SLogic
+ruleDeMorganOr = ruleFor groupDeMorgan "DeMorganOr" $
+   \x y -> Not (x :||: y)  :~>  Not x :&&: Not y
+
+ruleDeMorganAnd :: Rule SLogic
+ruleDeMorganAnd = ruleFor groupDeMorgan "DeMorganAnd" $
+   \x y -> Not (x :&&: y)  :~>  Not x :||: Not y
+
+-----------------------------------------------------------------------------
+-- Implication elimination
+
+ruleDefImpl :: Rule SLogic
+ruleDefImpl = ruleFor groupImplication "DefImpl" $
+   \x y -> x :->: y  :~>  Not x :||: y
+
+-----------------------------------------------------------------------------
+-- Equivalence elimination
+
+ruleDefEquiv :: Rule SLogic
+ruleDefEquiv = ruleFor groupEquivalence "DefEquiv" $
+   \x y -> x :<->: y  :~>  (x :&&: y) :||: (Not x :&&: Not y)
+ src/Domain/Logic/Strategies.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Strategies
+   ( dnfStrategy, cnfStrategy
+   , orRules, andRules, nnfStep, simplifyStep
+   , deMorgan, deMorganOr, deMorganAnd, distrAnd, distrOr
+   , eliminateImplEquiv
+   , specialDeMorganNot, specialDistrNot, specialGroupLiterals
+   ) where
+
+import Control.Monad
+import Data.List
+import Domain.Logic.Formula
+import Domain.Logic.GeneralizedRules
+import Domain.Logic.Rules
+import Domain.Logic.Utils
+import Ideas.Common.Library
+import Ideas.Common.Strategy.Legacy
+import Prelude hiding ((<*>))
+
+-----------------------------------------------------------------------------
+-- Normal forms
+
+dnfStrategy :: LabeledStrategy (Context SLogic)
+dnfStrategy = label "DNF" $ repeatS $
+   orRules <|> somewhereOr (nnfStep |> distrAnd)
+
+cnfStrategy :: LabeledStrategy (Context SLogic)
+cnfStrategy = label "CNF" $ repeatS $
+   andRules <|> somewhereAnd (nnfStep |> distrOr)
+
+-----------------------------------------------------------------
+-- Sub-strategies
+
+orRules :: LabeledStrategy (Context SLogic)
+orRules = label "OrRules" $ useRules
+   [ruleFalseOr, ruleTrueOr, ruleIdempOr, ruleAbsorpOr, ruleComplOr]
+
+andRules :: LabeledStrategy (Context SLogic)
+andRules = label "AndRules" $ useRules
+   [ruleFalseAnd, ruleTrueAnd, ruleIdempAnd, ruleAbsorpAnd, ruleComplAnd]
+
+-- A step towards Negation Normal Form (NNF)
+nnfStep :: Strategy (Context SLogic)
+nnfStep =
+      simplifyStep
+   |> (remove specialGroupLiterals >|> specialDistrNot >|> specialDeMorganNot)
+   |> (eliminateImplEquiv >|> deMorgan)
+
+simplifyStep :: LabeledStrategy (Context SLogic)
+simplifyStep = label "Simplify" $ oncetdPref $
+   orRules <|> andRules <|>
+   useRules [ruleNotTrue, ruleNotFalse, ruleDoubleNeg]
+
+deMorganOr :: Strategy (Context SLogic)
+deMorganOr = liftToContext generalRuleDeMorganOr >|> liftToContext ruleDeMorganOr
+
+deMorganAnd :: Strategy (Context SLogic)
+deMorganAnd = liftToContext generalRuleDeMorganAnd >|> liftToContext ruleDeMorganAnd
+
+deMorgan :: LabeledStrategy (Context SLogic)
+deMorgan = label "DeMorgan" $ somewhere $
+   deMorganOr <|> deMorganAnd
+
+distrAnd :: LabeledStrategy (Context SLogic)
+distrAnd = label "DistrAnd" $ oncebuPref $
+   liftToContext generalRuleDistrAnd >|> liftToContext ruleDistrAnd
+
+distrOr :: LabeledStrategy (Context SLogic)
+distrOr = label "DistrOr" $ oncebuPref $
+   liftToContext generalRuleDistrOr >|> liftToContext ruleDistrOr
+
+eliminateImplEquiv :: LabeledStrategy (Context SLogic)
+eliminateImplEquiv = label "EliminateImplEquiv" $
+   somewhere (liftToContext ruleDefImpl)
+   >|>
+   oncebuPref (liftToContext ruleDefEquiv)
+
+-- specialization of De Morgan rules with a not inside (gives higher priority)
+specialDeMorganNot :: LabeledStrategy (Context SLogic)
+specialDeMorganNot = label "SpecialDeMorganNot" $ somewhere $
+   (check (cond disjunctions) <*> deMorganOr) <|>
+   (check (cond conjunctions) <*> deMorganAnd)
+ where
+   cond f ctx = case currentInContext ctx of
+                   Just (Not x) ->
+                      let ys = f x in length ys > 1 && any notComposed ys
+                   _ -> False
+   notComposed (Not (Var _)) = False
+   notComposed (Not _)       = True
+   notComposed _             = False
+
+specialDistrNot :: LabeledStrategy (Context SLogic)
+specialDistrNot = label "SpecialDistrNot" $ somewhere $ liftToContext $
+   (check condOr  <*> ruleDistrOr) <|>
+   (check condAnd <*> ruleDistrAnd)
+ where
+    condOr (p :||: q) = cond conjunctions p q
+    condOr _          = False
+
+    condAnd (p :&&: q) = cond disjunctions p q
+    condAnd _          = False
+
+    cond f p q = (p `negatedIn` qs && length qs == 2) ||
+                 (q `negatedIn` ps && length ps == 2)
+     where
+        ps = f p
+        qs = f q
+
+    negatedIn (Not x) xs = x `elem` xs || (Not (Not x) `elem` xs)
+    negatedIn x xs       = Not x `elem` xs
+
+specialGroupLiterals :: LabeledStrategy (Context SLogic)
+specialGroupLiterals = label "SpecialSort" $ somewhere $
+   liftToContext groupLiteralsOr <|> liftToContext groupLiteralsAnd
+
+-- p \/ q \/ ~p  ~> reorder p and ~p
+-- p \/ q \/ p   ~> reorder p's
+groupLiteralsOr :: Rule SLogic
+groupLiteralsOr = siblingOf groupCommutativity $ ruleMaybe "ComplOr.sort" $ \p -> do
+   let xs = disjunctions p
+       ys = sortLiterals xs
+   guard (xs /= ys)
+   return (ors ys)
+
+-- p /\ q /\ ~p  ~> reorder p and ~p
+-- p /\ q /\ p   ~> reorder p's
+groupLiteralsAnd :: Rule SLogic
+groupLiteralsAnd = siblingOf groupCommutativity $ ruleMaybe "ComplAnd.sort" $ \p -> do
+   let xs = conjunctions p
+       ys = sortLiterals xs
+   guard (xs /= ys)
+   return (ands ys)
+
+sortLiterals :: [SLogic] -> [SLogic]
+sortLiterals [] = []
+sortLiterals (p:ps) = p : ys ++ sortLiterals zs
+ where
+   (ys, zs) = partition (\x -> x == p || x `isNegated` p) ps
+   isNegated (Not x) y = y `elem` [x, Not (Not x)]
+   isNegated x y       = y == Not x
+
+-- local helper function
+useRules :: [Rule SLogic] -> Strategy (Context SLogic)
+useRules = alternatives . map liftToContext
+ src/Domain/Logic/Utils.hs view
@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Utilities for the logic domain
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Utils
+   ( propositionalId, makeSimpleRule, makeListRule
+     -- groups of rules
+   , groupAbsorption, groupAssociativity, groupCommutativity, groupDeMorgan
+   , groupDistribution, groupIdempotency
+   , groupDoubleNegation, groupEquivalence, groupFalseComplement
+   , groupFalseConjunction, groupFalseDisjunction, groupNotTrue
+   , groupImplication, groupTrueComplement, groupTrueConjunction
+   , groupTrueDisjunction, groupNotFalse
+     -- other utility functions
+   , makeInvRule, makeInvRuleWithUse
+   , collect, andView, orView, eqView
+   , somewhereOr, somewhereAnd
+   , (===), (==>), (<=>)
+   ) where
+
+import Domain.Logic.Formula
+import Ideas.Common.Library
+
+propositionalId :: Id
+propositionalId = newId "logic.propositional"
+
+makeListRule :: String -> (a -> [a]) -> Rule a
+makeListRule s = makeRule (propositionalId # s)
+
+makeSimpleRule :: String -> (a -> Maybe a) -> Rule a
+makeSimpleRule s = makeRule (propositionalId # s)
+
+-----------------------------------------------------------------------------
+-- Groups of rules
+
+groupAbsorption, groupAssociativity, groupCommutativity, groupDeMorgan,
+   groupDistribution, groupIdempotency :: Id
+groupAbsorption    = makeGroup "Absorption"
+groupAssociativity = makeGroup "Associativity"
+groupCommutativity = makeGroup "Commutativity"
+groupDeMorgan      = makeGroup "DeMorgan"
+groupDistribution  = makeGroup "Distribution"
+groupIdempotency   = makeGroup "Idempotency"
+
+groupDoubleNegation, groupEquivalence, groupFalseComplement,
+   groupFalseConjunction, groupFalseDisjunction, groupNotTrue,
+   groupImplication, groupTrueComplement, groupTrueConjunction,
+   groupTrueDisjunction, groupNotFalse :: Id
+groupDoubleNegation   = makeGroup "doublenegation"
+groupEquivalence      = makeGroup "equivalence"
+groupFalseComplement  = makeGroup "falsecomplement"
+groupFalseConjunction = makeGroup "falseconjunction"
+groupFalseDisjunction = makeGroup "falsedisjunction"
+groupNotTrue          = makeGroup "group-nottrue"
+groupImplication      = makeGroup "implication"
+groupTrueComplement   = makeGroup "truecomplement"
+groupTrueConjunction  = makeGroup "trueconjunction"
+groupTrueDisjunction  = makeGroup "truedisjunction"
+groupNotFalse         = makeGroup "group-notfalse"
+
+makeGroup :: String -> Id
+makeGroup s = describe "Group of logic rules" (propositionalId # s)
+
+-----------------------------------------------------------------------------
+-- Inverse of a rule
+
+makeInvRule :: IsId n => (a -> a -> Bool) -> n -> Rule a -> Rule a
+makeInvRule sim name r =
+   addRecognizerBool eq $ setSiblings $ setBuggy (isBuggy r) $ makeRule name (const Nothing)
+ where
+   eq a b = any (sim a) (applyAll r b)
+   setSiblings n = foldr siblingOf n (ruleSiblings r)
+
+makeInvRuleWithUse :: (IsTerm a, IsTerm b, IsId n, Show a)
+                => (Context a -> Context a -> Bool) -> n -> Rule b -> Rule (Context a)
+makeInvRuleWithUse sim name r =
+   addRecognizerBool eq $ setSiblings $ setBuggy (isBuggy r) $ makeRule name (const Nothing)
+ where
+   eq a b = any (sim a) (applyAll (somewhere (use r)) b)
+   setSiblings n = foldr siblingOf n (ruleSiblings r)
+
+collect :: View a (a, a) -> Isomorphism a [a]
+collect v = f <-> g
+ where
+   f x = maybe [x] (\(y, z) -> f y ++ f z) (match v x)
+   g   = foldr1 (curry (build v))
+
+andView, orView, eqView :: View (Logic a) (Logic a, Logic a)
+andView = makeView isAnd (uncurry (<&&>))
+orView  = makeView isOr  (uncurry (<||>))
+eqView  = makeView isEq  (uncurry equivalent)
+ where
+   isEq (p :<->: q) = Just (p, q)
+   isEq _           = Nothing
+
+-- A specialized variant of the somewhere traversal combinator. Apply
+-- the strategy only at (top-level) disjuncts
+somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)
+somewhereOr = somewhereWhen $ \a -> 
+   case currentInContext a of
+      Just (_ :||: _) -> False
+      _               -> True
+
+somewhereAnd :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)
+somewhereAnd = somewhereWhen $ \a -> 
+   case currentInContext a of
+      Just (_ :&&: _) -> False
+      _               -> True
+
+infix 6 ===, ==>, <=>
+
+(===), (==>), (<=>) :: Eq a => Logic a -> Logic a -> Bool
+(===)   = eqLogic
+p ==> q = tautology (p :->: q)
+p <=> q = tautology (p :<->: q)
+ src/Domain/Logic/Views.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Logic.Views
+   ( (.<->.), (.->.), (.&&.), (.||.)
+   , simplify, pushNot, pushNotWith
+   , orView, andView
+   ) where
+
+import Domain.Logic.Formula
+import Domain.Algebra.SmartGroup
+import Ideas.Common.Id
+import Ideas.Common.View hiding (simplify)
+
+------------------------------------------------------------
+-- Smart constructors
+
+infixr 2 .<->.
+infixr 3 .->.
+
+(.<->.) :: Logic a -> Logic a -> Logic a
+T .<->. q = q
+F .<->. q = nott q
+p .<->. T = p
+p .<->. F = nott p
+p .<->. q = p :<->: q
+
+(.->.) :: Logic a -> Logic a -> Logic a
+T .->. q = q
+F .->. _ = T
+_ .->. T = T
+p .->. F = nott p
+p .->. q = p :->: q
+
+{- (.||.) :: Logic a -> Logic a -> Logic a
+T .||. _ = T
+F .||. q = q
+_ .||. T = T
+p .||. F = p
+p .||. q = p :||: q
+
+(.&&.) :: Logic a -> Logic a -> Logic a
+T .&&. q = q
+F .&&. _ = F
+p .&&. T = p
+_ .&&. F = F
+p .&&. q = p :&&: q -}
+
+nott :: Logic a -> Logic a
+nott (Not p) = p
+nott p       = Not p
+
+-------------------------------------------------
+-- Views and transformations
+
+simplify :: Logic a -> Logic a
+simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F)
+
+pushNotWith :: (a -> Logic a) -> Logic a -> Logic a
+pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F)
+ where
+   rec logic =
+      case logic of
+         Not p :<->: q -> p     .<->. q
+         p :<->: Not q -> p     .<->. q
+         p :<->: q     -> rec p .<->. q
+         p :->:  q     -> p     .&&.  rec q
+         p :||:  q     -> rec p .&&.  rec q
+         p :&&:  q     -> rec p .||.  rec q
+         Not p         -> p
+         T             -> F
+         F             -> T
+         Var a         -> f a
+
+pushNot :: Logic a -> Logic a
+pushNot = pushNotWith (nott . Var)
+
+orView :: View (Logic a) [a]
+orView = "logic.orView" @> makeView (($ []) . f) (foldr ((.||.) . Var) F)
+ where
+   f (p :||: q) = (>>= f p) .  f q
+   f (Var a)    = return . (a:)
+   f F          = return
+   f _          = const Nothing
+
+andView :: View (Logic a) [a]
+andView = "logic.andView" @> makeView (($ []) . f) (foldr ((.&&.) . Var) T)
+ where
+   f (p :&&: q) = (>>= f p) .  f q
+   f (Var a)    = return . (a:)
+   f T          = return
+   f _          = const Nothing
+ src/Domain/Math/Approximation.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Approximation where
+
+import Data.List
+
+type Function = Double -> Double
+
+type Approximation = [Double]
+
+------------------------------------------------------------
+-- Precision of a floating-point number
+
+precision :: Int -> Double -> Double
+precision n = (/a) . fromInteger . round . (*a)
+ where a = 10 Prelude.^ max 0 n
+
+------------------------------------------------------------
+-- Stop criteria
+
+within :: Double -> Approximation -> Double
+within _ []  = error "within []"
+within _ [x] = x
+within d (x:xs@(y:_))
+   | abs (x-y) <= d = x
+   | otherwise      = within d xs
+
+relative :: Double -> Approximation -> Double
+relative _ []  = error "relative []"
+relative _ [x] = x
+relative d (x:xs@(y:_))
+   | abs (x-y) <= d*abs y = x
+   | otherwise            = relative d xs
+
+------------------------------------------------------------
+-- Root-finding algorithms
+
+-- http://en.wikipedia.org/wiki/Bisection_method
+bisection :: Function -> [Double] -> Approximation
+bisection f ds =
+   case partition ((<= 0) . f) ds of
+      (lo:_, hi:_) -> run hi lo
+      _            -> []
+ where
+   run hi lo
+      | fm <= 0   = mid : run hi mid
+      | otherwise = mid : run mid lo
+    where
+      mid = (hi+lo) / 2
+      fm  = f mid
+
+-- http://en.wikipedia.org/wiki/Newton's_method
+newton :: Function -> Function -> Double -> Approximation
+newton f df = iterate next
+ where
+    next a
+       | dfa == 0  = a
+       | otherwise = a - f a / dfa
+     where
+       dfa = df a
+
+------------------------------------------------------------
+-- Finding the derivative of a function
+
+derivative :: Double -> Function -> Function
+derivative delta f x = (f (x+delta) - f (x-delta)) / (2*delta)
+
+-- Test code
+{-
+same f g = sum [ abs (f x - g x) | x <- [0,0.01..6] ]
+
+test1 = same (derivative 0.01 sin) cos
+test2 = same (derivative 0.01 cos) (negate . sin) -}
+ src/Domain/Math/CleanUp.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.CleanUp
+   ( cleanUpRelations, cleanUpRelation, cleanUpExpr
+   , cleanUpSimple, cleanUpView, cleanUpACView
+   , assocExpr, acExpr, smart, assocPlus, assocTimes
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Data.Ratio
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Data.SquareRoot (fromSquareRoot)
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views (rationalView, integerView)
+import Domain.Math.Power.OldViews (powerFactorViewWith)
+import Domain.Math.SquareRoot.Views (squareRootViewWith)
+import Ideas.Common.Classes
+import Ideas.Utils.Prelude (fixpoint)
+import Ideas.Utils.Uniplate
+import Ideas.Common.View
+import Prelude hiding ((^), recip)
+import qualified Prelude
+
+----------------------------------------------------------------------
+-- Root simplification
+
+simplerRoot :: Rational -> Integer -> Expr
+simplerRoot a b
+   | b < 0          = 1 ./. simplerRoot a (abs b)
+   | a < 0 && odd b = neg (simplerRoot (abs a) b)
+   | otherwise      = f (numerator a) b ./. f (denominator a) b
+ where
+   f x y
+      | x == 0              = 0
+      | y == 0 || x <= 0    = root (fromIntegral x) (fromIntegral y)
+      | e Prelude.^ y == x  = fromIntegral e
+      | otherwise           = root (fromIntegral x) (fromIntegral y)
+    where
+      e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y))
+
+------------------------------------------------------------
+-- Cleaning up
+
+cleanUpSimple :: Expr -> Expr
+cleanUpSimple = fixpoint (transform (smart . f))
+ where
+   f = simplifyWith (assocPlus rationalView) sumView
+
+cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr)
+cleanUpRelations = noDuplicates . foldMap cleanUpRelation
+
+cleanUpRelation :: Relation Expr -> OrList (Relation Expr)
+cleanUpRelation = f . fmap cleanUpBU
+ where
+   f rel
+      | any falsity (universe a ++ universe b) = false
+      | a == b    = fromBool (relationType rel `elem` equals)
+      | otherwise =
+           case (match rationalView a, match rationalView b) of
+              (Just r, Just s) -> fromBool (eval (relationType rel) r s)
+              _                -> singleton rel
+    where
+      (a, b) = (leftHandSide rel, rightHandSide rel)
+
+   equals =
+      [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately]
+
+   falsity :: Expr -> Bool
+   falsity (Sqrt e)  = maybe False (<0)  (match rationalView e)
+   falsity (_ :/: e) = maybe False (==0) (match rationalView e)
+   falsity _         = False
+
+-- also simplify square roots
+cleanUpExpr :: Expr -> Expr
+cleanUpExpr = fixpoint $
+   cleanUpBU . transform (simplify (squareRootViewWith rationalView))
+
+cleanUpView, cleanUpACView :: View Expr Expr
+cleanUpView   = makeView (return . cleanUpExpr) id
+cleanUpACView = makeView (return . acExpr . cleanUpExpr) id
+
+-- normalize expr with associativity and commutative rules for + and *
+assocExpr, acExpr :: Expr -> Expr
+assocExpr = normExpr id
+acExpr    = normExpr sort
+
+normExpr :: ([Expr] -> [Expr]) -> Expr -> Expr
+normExpr f = rec
+ where
+   rec expr =
+      case (from sumView expr, from productView expr) of
+         (xs, _) | length xs > 1 ->
+            to sumView $ f $ map rec xs
+         (_, (b, xs)) | length xs > 1 ->
+            to productView (b, f $ map rec xs)
+         _ ->
+            descend rec expr
+
+------------------------------------------------------------
+-- Associativity
+
+assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr]
+assocPlus  = assocOp (+)
+assocTimes = assocOp (*)
+
+assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr]
+assocOp op v = rec . map (simplify v)
+ where
+   rec (x:y:zs) =
+      case canonical v (op x y) of
+         Just a  -> rec (a:zs)
+         Nothing -> x:rec (y:zs)
+   rec xs = xs
+
+------------------------------------------------------------
+-- Fixpoint of a bottom-up traversal
+
+cleanUpBU :: Expr -> Expr
+cleanUpBU = {- fixpoint $ -} transform $ \e ->
+   simplify myView $
+   fromMaybe (smart e) $
+      canonical rationalView e
+    `mplus`
+      fmap (transform smart) (canonical specialSqrtOrder e)
+      -- Just simplify order of terms with square roots for now
+    `mplus` do
+      let f xs | length xs > 1 = return (assocPlus rationalView xs)
+          f _ = Nothing
+      canonicalWithM f sumView e
+    `mplus`
+      canonical myView e
+    `mplus` do
+      let f (b, xs) | length xs > 1 = return (b, assocTimes rationalView xs)
+          f _ = Nothing
+      canonicalWithM f simpleProductView e
+ where
+   myView = powerFactorViewWith rationalView
+
+specialSqrtOrder :: View Expr [Expr]
+specialSqrtOrder = toView sumView >>> makeView f id
+ where
+   make = match (squareRootViewWith rationalView)
+   g    = isNothing . fromSquareRoot . snd
+   f xs = do
+      ys <- mapM make xs
+      return $ map fst $ sortBy (comparing g) $ zip xs ys
+
+smart :: Expr -> Expr
+smart (a :*: b) = a .*. b
+smart (a :/: b) = a ./. b
+smart expr@(Sym s [x, y])
+   | isPowerSymbol s = x .^. y
+   | isRootSymbol  s = fromMaybe expr $
+        simplerRoot <$> match rationalView x <*> match integerView y
+smart (Negate a) = neg a
+smart (a :+: b) = a .+. b
+smart (a :-: b) = a .-. b
+smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2
+smart e = e
+ src/Domain/Math/Data/MultivariatePolynomial.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Data.MultivariatePolynomial where++import Control.Monad+import qualified Data.Map as M+import Data.Maybe+import Domain.Algebra.Field+import Domain.Math.CleanUp+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Ideas.Common.View+import Ideas.Utils.Prelude+import Ideas.Utils.Uniplate+import Prelude hiding (subtract)+import Recognize.Expr.Normalform (distributeExponent, rewriteSqrt)++multivariatePolynomialView :: View Expr (MultivariatePolynomial Expr)+multivariatePolynomialView = makeView toMultivariatePolynomial fromMultivariatePolynomial++multivariatePolynomialViewWith :: View Expr a -> View Expr (MultivariatePolynomial a)+multivariatePolynomialViewWith v = multivariatePolynomialView >>> traverseView v++toMultivariatePolynomial :: Expr -> Maybe (MultivariatePolynomial Expr)+toMultivariatePolynomial expr =+   case fixpoint (transform (distributeExponent . rewriteSqrt)) expr of+      x :+: y -> (+) <$> toMultivariatePolynomial x <*> toMultivariatePolynomial y+      x :*: y -> (*) <$> toMultivariatePolynomial x <*> toMultivariatePolynomial y+      x :-: y -> (-) <$> toMultivariatePolynomial x <*> toMultivariatePolynomial y+      Negate e -> (0-) <$> toMultivariatePolynomial e+      Nat e -> Just (con $ fromInteger e)+      x :/: y -> join (divide <$> toMultivariatePolynomial x <*> return y) --match rationalView (cleanUpExpr y)) -- SAVE DIV!+      Sqrt _ -> Nothing -- flip expo (1/2) <$> (toMultivariatePolynomial e)+      Number d -> let t = toRational d in Just (con $ fromRational t ) -- (numerator t) % (denominator t))+      Var s -> Just (var s)+      Sym s [x,y] | isPowerSymbol s -> expo <$> toMultivariatePolynomial x <*> match naturalView (cleanUpExpr y)+      Sym _ _ -> Nothing -- Sym s <$> map toMultivariatePolynomial es++fromMultivariatePolynomial :: MultivariatePolynomial Expr -> Expr+fromMultivariatePolynomial (Sum m) | m == M.empty = 0+                                   | otherwise = foldr1 (.+.) [ fromFactors fac .*. r | (fac, r) <- M.toList m ]++fromFactors :: Factors -> Expr+fromFactors (Product m) | m == M.empty = 1+                        | otherwise = foldr1 (.*.) [+                                        if n == 1 then+                                          Var x+                                        else+                                          Var x ** fromInteger n+                                        | (x, n) <- M.toList m ]++multivariatePolynomialToMap :: MultivariatePolynomial a -> M.Map Factors a+multivariatePolynomialToMap (Sum s) = s+-- 2ab+b^2-2ab+a^2+ex :: MultivariatePolynomial Expr+ex = 2 * a * b + expo b 2 - 2 * a * b + expo a 2+ where+   a = var "a"+   b = var "b"++type Var = String++-- invariant: values should not be 0+newtype MultivariatePolynomial a = Sum (M.Map Factors a)+ deriving Eq++instance Show (MultivariatePolynomial Expr) where+  show = show . fromMultivariatePolynomial++-- invariant: values (exponents) must be > 0+newtype Factors = Product (M.Map Var Integer) -- a^3 b^1 c^2+  deriving (Eq, Ord)++instance Show Factors where+  show = show . fromFactors++instance Functor MultivariatePolynomial where+  fmap f (Sum xs) = Sum (f <$> xs)++instance Foldable MultivariatePolynomial where+  foldMap f (Sum xs) = foldMap f xs++instance Traversable MultivariatePolynomial where+   sequenceA (Sum m) = Sum <$> sequenceA m++-- smart constructor that takes care of MultivariatePolynomial's invariant+mkSum :: (Eq a, Field a) => M.Map Factors a -> MultivariatePolynomial a+mkSum = Sum . M.filter (/= zero)++----------------------++instance (Num a, Eq a, Field a) => Num (MultivariatePolynomial a) where+   (+) = plus+   (-) = subtract+   (*) = times+   negate = subtract 0+   fromInteger = con . fromInteger++var :: (Eq a, Field a) => Var -> MultivariatePolynomial a+var x = mkSum (M.singleton (varF x) one)++con :: (Eq a, Field a) => a -> MultivariatePolynomial a+con n = mkSum (M.singleton oneF n)++plus :: (Eq a, Field a) => MultivariatePolynomial a -> MultivariatePolynomial a -> MultivariatePolynomial a+plus (Sum m1) (Sum m2) = mkSum (M.unionWith (|+|) m1 m2)++negateMV ::  (Eq a,Num a, Field a) => MultivariatePolynomial a -> MultivariatePolynomial a+negateMV (Sum s) = Sum (M.map negate s)++subtract :: (Eq a,Num a, Field a) => MultivariatePolynomial a -> MultivariatePolynomial a -> MultivariatePolynomial a+subtract a b = a `plus` negateMV b++times :: (Eq a, Field a) => MultivariatePolynomial a -> MultivariatePolynomial a -> MultivariatePolynomial a+times p (Sum m) = foldr plus (con zero) [ times3 r (times2 fac p) | (fac, r) <- M.toList m ]++times2 :: (Eq a, Field a) => Factors -> MultivariatePolynomial a -> MultivariatePolynomial a+times2 f (Sum m) = mkSum (M.mapKeys (timesF f) m)++times3 :: (Eq a, Field a) => a -> MultivariatePolynomial a -> MultivariatePolynomial a+times3 r (Sum m) = mkSum (M.map (|*| r) m)++divide :: (Eq a, Field a) => MultivariatePolynomial a -> a -> Maybe (MultivariatePolynomial a) -- eigenlijk Maybe: r /= 0, dus safe division+divide p r | r == zero = Nothing+           | otherwise = Just $ times p (con (one |/| r))++unsafeDivide :: (Eq a, Field a) => MultivariatePolynomial a -> a -> MultivariatePolynomial a+unsafeDivide p r = fromMaybe (error "unsafe multivariate polynomial division by zero") (divide p r)++-- we would like to have expo :: MultivariatePolynomial -> Rational -> MultivariatePolynomial+-- but, then we would need to factorize the MultivariatePolynomial: https://en.wikipedia.org/wiki/Factorization_of_polynomials+expo :: (Eq a, Field a) => MultivariatePolynomial a -> Integer -> MultivariatePolynomial a -- kan vast slimmer+expo _ 0 = con one+expo p n = times p (expo p (n-1))++----------------------+varF :: Var -> Factors+varF x = Product (M.singleton x 1)++oneF :: Factors+oneF = Product M.empty++timesF :: Factors -> Factors -> Factors+timesF (Product m1) (Product m2) = Product (M.unionWith (+) m1 m2)
+ src/Domain/Math/Equation/BalanceRules.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Equation.BalanceRules
+   ( plusRule, minusRule, timesRule, divisionRule
+   ) where
+
+import Control.Monad
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+factorRef, termRef :: Ref Expr
+factorRef = makeRef "factor"
+termRef   = makeRef "term"
+
+plusRule :: Functor f => ParamTrans Expr (f Expr)
+plusRule = parameter1 termRef $ \a -> Just . fmap (:+: a)
+
+minusRule :: Functor f => ParamTrans Expr (f Expr)
+minusRule = parameter1 termRef $ \a -> Just . fmap (:-: a)
+
+timesRule :: Functor f => ParamTrans Expr (f Expr)
+timesRule = parameter1 factorRef $ \a -> unlessZero a . fmap (a :*:)
+
+divisionRule :: ParamTrans Expr (Equation Expr)
+divisionRule = parameter1 factorRef $ \a -> unlessZero a . fmap (:/: a)
+
+unlessZero :: Expr -> a -> Maybe a
+unlessZero e a = do
+   r <- matchM rationalView e
+   guard (r /= 0)
+   return a
+ src/Domain/Math/Equation/CoverUpRules.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Equation.CoverUpRules
+   ( coverUpRules, coverUpRulesOr
+   , coverUp, coverUpOrs
+   , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight
+   , coverUpTimes, coverUpNegate
+   , coverUpNumerator, coverUpDenominator, coverUpSqrt
+     -- parameterized rules
+   , ConfigCoverUp, configName, predicateCovered, predicateCombined
+   , coverLHS, coverRHS, configCoverUp
+   , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith
+   , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith
+   , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
+     -- temporarily exported
+   , coverUpBinaryRule, commOp, flipOp
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Library hiding ((<>))
+
+---------------------------------------------------------------------
+-- Constructors for cover-up rules
+
+coverUpFunction :: (Traversable f, Relational r)
+                   => (Expr -> [(Expr, Expr)])
+                   -> (Expr -> Expr -> [f Expr])
+                   -> ConfigCoverUp -> r Expr -> [f (r Expr)]
+coverUpFunction fm fb cfg eq0 =
+   (guard (coverLHS cfg) >> coverLeft eq0) ++
+   (guard (coverRHS cfg) >> coverRight eq0)
+ where
+   coverRight   = map (fmap flipSides) . coverLeft . flipSides
+   coverLeft eq = do
+      (e1, e2) <- fm (leftHandSide eq)
+      -- guard (predicateCovered  cfg e1)
+      new <- fb (rightHandSide eq) e2
+      _   <- mapM (guard . predicateCombined cfg) new
+      return (fmap (constructor eq e1) new)
+
+coverUpBinaryOrRule :: Relational r
+                   => String -> (Expr -> [(Expr, Expr)])
+                   -> (Expr -> Expr -> [OrList Expr])
+                   -> ConfigCoverUp -> Rule (OrList (r Expr))
+coverUpBinaryOrRule opName fm fb cfg =
+   let name = coverUpRuleName opName (configName cfg)
+   in makeRule name $ oneDisjunct $ coverUpFunction fm fb cfg
+
+coverUpBinaryRule :: Relational r => String
+                  -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr)
+                  -> ConfigCoverUp -> Rule (r Expr)
+coverUpBinaryRule opName fm fb cfg =
+   let name = coverUpRuleName opName (configName cfg)
+       fb2 a b = [[fb a b]]
+   in makeRule name $ map head . coverUpFunction fm fb2 cfg
+
+coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr)
+               -> ConfigCoverUp -> Rule (r Expr)
+coverUpUnaryRule opName fm fb =
+   coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb)
+
+coverUpRuleName :: String -> String -> Id
+coverUpRuleName opName cfg =
+   let f = if null cfg then newId else ( cfg # )
+   in "algebra.equations.coverup" # f opName
+
+---------------------------------------------------------------------
+-- Configuration for cover-up rules
+
+data ConfigCoverUp = Config
+   { configName        :: String
+   , predicateCovered  :: Expr -> Bool
+   , predicateCombined :: Expr -> Bool
+   , coverLHS          :: Bool
+   , coverRHS          :: Bool
+   }
+
+-- Default configuration: cover-up part with variables
+configCoverUp :: ConfigCoverUp
+configCoverUp = Config
+   { configName        = ""
+   , predicateCovered  = hasSomeVar
+   , predicateCombined = hasNoVar
+   , coverLHS          = True
+   , coverRHS          = True
+   }
+
+---------------------------------------------------------------------
+-- Parameterized cover-up rules
+
+coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr))
+coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb
+ where
+   fb rhs e2 = do
+      n <- isNat e2
+      guard (n > 0)
+      let new1 = root rhs (fromIntegral n)
+          new2 = neg new1
+      return $ singleton new1 <>
+         if even n && new1 /= new2 then singleton new2 else false
+
+coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-)
+
+coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+)
+
+coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))
+
+-- | Negations are pushed inside
+coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpTimesWith = coverUpBinaryRule "times" (map signs . commOp . matchM timesView) (/)
+ where
+   signs (Negate x, y) = (x, neg y) -- puts negation at combined term
+   signs (x, y) = (x, y)
+
+coverUpNegateWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpNegateWith = coverUpUnaryRule "negate" isNegate negate
+
+-- | Negations are pushed inside
+coverUpNumeratorWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpNumeratorWith = coverUpBinaryRule "numerator" (matchM divView) (*)
+
+-- | Negations are pushed inside
+coverUpDenominatorWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/))
+
+coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x)
+ where
+   isSqrt (Sqrt a) = return a
+   isSqrt _        = []
+
+---------------------------------------------------------------------
+-- Cover-up rules for variables
+
+coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr)
+coverUpOrs = foldMap  (f . coverUp)
+ where
+   f :: Equation Expr -> OrList (Equation Expr)
+   f eq = case apply coverUpPower (singleton eq) of
+             Just xs -> coverUpOrs xs
+             Nothing -> singleton eq
+
+coverUp :: Equation Expr -> Equation Expr
+coverUp eq =
+   case mapMaybe (`apply` eq) coverUpRules of
+      hd:_ -> coverUp hd
+      _    -> eq
+
+coverUpRulesOr :: IsTerm a => [Rule (Context a)]
+coverUpRulesOr = use coverUpPower : map use coverUpRules
+
+coverUpRules :: [Rule (Equation Expr)]
+coverUpRules =
+   [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate
+   , coverUpTimes, coverUpNumerator, coverUpDenominator, coverUpSqrt
+   ]
+
+coverUpPower :: Rule (OrList (Equation Expr))
+coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate,
+   coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr)
+
+coverUpPower       = coverUpPowerWith       configCoverUp
+coverUpPlus        = coverUpPlusWith        configCoverUp
+coverUpMinusLeft   = coverUpMinusLeftWith   configCoverUp
+coverUpMinusRight  = coverUpMinusRightWith  configCoverUp
+coverUpTimes       = coverUpTimesWith       configCoverUp
+coverUpNegate      = coverUpNegateWith      configCoverUp
+coverUpNumerator   = coverUpNumeratorWith   configCoverUp
+coverUpDenominator = coverUpDenominatorWith configCoverUp
+coverUpSqrt        = coverUpSqrtWith        configCoverUp
+
+---------------------------------------------------------------------
+-- Some helper-functions
+
+commOp :: MonadPlus m => m (a, a) -> m (a, a)
+commOp m = do
+   (a, b) <- m
+   return (a, b) `mplus` return (b, a)
+
+flipOp :: Monad m => m (a, a) -> m (a, a)
+flipOp = fmap (\(x, y) -> (y, x))
+
+isNat :: MonadPlus m => Expr -> m Integer
+isNat (Nat n) = return n
+isNat _       = mzero
+ src/Domain/Math/Equation/Views.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Equation.Views
+   ( relationSolvedForm, relationsSolvedForm
+   , equationSolvedForm, equationsSolvedForm, equationSolvedWith
+   ) where
+
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Library
+
+relationsSolvedForm :: (Traversable f, Relational g) =>
+   View (f (g Expr)) (f (Expr -> Expr -> g Expr, String, Expr))
+relationsSolvedForm = "relations.solved" @> traverseView relationSolvedForm
+
+-- The variable may appear on one of the sides of the relation (right-hand side
+-- is thus allowed), but must be isolated
+relationSolvedForm :: Relational f =>
+   View (f Expr) (Expr -> Expr -> f Expr, String, Expr)
+relationSolvedForm = "relation.solved" @> makeView f g
+ where
+   f r = case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of
+            (Just x, Nothing) | withoutVar x (rightHandSide r) ->
+               return (constructor r, x, rightHandSide r)
+            (Nothing, Just x) | withoutVar x (leftHandSide r) ->
+               return (flip (constructor r), x, leftHandSide r)
+            _ -> Nothing
+   g (make, s, e) = make (Var s) e
+
+-------------------------------------------------------------
+-- Views on equations
+
+equationsSolvedForm :: View (OrList (Equation Expr)) (OrList (String, Expr))
+equationsSolvedForm = "equations.solved" @> traverseView equationSolvedForm
+
+equationSolvedForm :: View (Equation Expr) (String, Expr)
+equationSolvedForm = "equation.solved" @> makeView f g
+ where
+   f (Var x :==: e) | withoutVar x e =
+      return (x, e)
+   f _ = Nothing
+   g (s, e) = Var s :==: e
+
+equationSolvedWith :: View Expr a -> View (Equation Expr) (String, a)
+equationSolvedWith v = "equation.solved-with" @> makeView f g
+ where
+   f (lhs :==: rhs) = do
+      x <- getVariable lhs
+      a <- match v rhs
+      return (x, a)
+   g (s, a) = Var s :==: build v a
+ src/Domain/Math/Numeric/Generators.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Numeric.Generators
+   ( integerGenerator, rationalGenerator, numGenerator
+   , ratioGen, ratioExprGen, ratioExprGenNonZero, nonZero
+   ) where
+
+import Control.Monad
+import Data.Ratio
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+import Test.QuickCheck hiding (function)
+
+-------------------------------------------------------------------
+-- Generators
+
+-- tailored towards generating "int" expressions (also prevents
+-- division by zero)
+integerGenerator :: Int -> Gen Expr
+integerGenerator = symbolGenerator extras numSymbols
+ where
+   extras n = natGenerator : [ divGen n | n > 0 ]
+   divGen n = do
+      e1 <- integerGenerator (n `div` 2)
+      e2 <- integerGenerator (n `div` 2)
+      case (match integerView e1, match integerView e2) of
+         (Just a, Just b)
+            | b == 0 -> elements
+                 [ e1 :/: (e2 + 1), e1 :/: (e2 - 1)
+                 , e1 :/: (1 + e2), e1 :/: (1 - e2)
+                 ]
+            | a `mod` b == 0 ->
+                 return (e1 :/: e2)
+            | otherwise -> do -- change numerator
+                i <- arbitrary
+                let m1 = fromInteger ((a `mod` b) + i*b)
+                    m2 = fromInteger (b - (a `mod` b) + i*b)
+                elements
+                   [ (e1 - m1) :/: e2, (m1 - e1) :/: e2
+                   , (e1 + m2) :/: e2, (m2 + e1) :/: e2
+                   ]
+         _ -> error "integerGenerator"
+
+-- Prevents division by zero
+rationalGenerator :: Int -> Gen Expr
+rationalGenerator = symbolGenerator extras numSymbols
+ where
+   extras n = natGenerator : [ divGen n | n > 0 ]
+   divGen n = do
+      e1 <- rationalGenerator (n `div` 2)
+      e2 <- rationalGenerator (n `div` 2)
+      case match rationalView e2 of
+         Just b | b == 0 -> return e1
+         _               -> return (e1 :/: e2)
+
+-- Also generates "division-by-zero" expressions
+numGenerator :: Int -> Gen Expr
+numGenerator = symbolGenerator (const [natGenerator]) $
+   (divideSymbol, Just 2):numSymbols
+
+ratioExprGen :: Int -> Gen Expr
+ratioExprGen n = fromRational <$> ratioGen n (n `div` 4)
+
+ratioExprGenNonZero :: Int -> Gen Expr
+ratioExprGenNonZero n = fmap fromRational $ nonZero $ ratioGen n (n `div` 4)
+
+nonZero :: (Eq a,Num a) => Gen a -> Gen a
+nonZero = fmap (\a -> if a==0 then 1 else a)
+
+numSymbols :: [(Symbol, Maybe Int)]
+numSymbols = (negateSymbol, Just 1)
+           : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2))
+
+-------------------------------------------------------------------
+-- Helpers
+
+symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr
+symbolGenerator extras syms = f
+ where
+   f n = oneof $  map (g n) (filter (\(_, a) -> n > 0 || a == Just 0) syms)
+               ++ extras n
+   g n (s, arity) = do
+      i  <- case arity of
+               Just i  -> return i
+               Nothing -> choose (0, 5)
+      as <- replicateM i (f (n `div` i))
+      return (function s as)
+
+natGenerator :: Gen Expr
+natGenerator = Nat . abs <$> arbitrary
+
+-- | Prevents a bias towards small numbers
+ratioGen :: Integral a => Int -> Int -> Gen (Ratio a)
+ratioGen n m = do
+   a <- choose (-n, n)
+   b <- succ . abs <$> choose (-m, m)
+   c <- choose (1-b, b-1)
+   return (fromIntegral a + (fromIntegral c / fromIntegral b))
+ src/Domain/Math/Numeric/Rules.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Numeric.Rules where++import Control.Applicative+import Control.Monad+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Ideas.Common.Library++------------------------------------------------------------+-- Rules++alg :: String+alg = "algebra.manipulation"++calcRuleName :: String -> String -> String+calcRuleName opName viewName =+   "arithmetic.operation." ++ viewName ++ "." ++ opName++calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e+calcBinRule opName op m viewName v =+   makeRule (calcRuleName opName viewName) $ \e ->+   do (e1, e2) <- m e+      a <- match v e1+      b <- match v e2+      return (build v (op a b))++calcPlusWith :: Num a => String -> View Expr a -> Rule Expr+calcPlusWith = calcBinRule "plus" (+) isPlus++calcMinusWith :: Num a => String -> View Expr a -> Rule Expr+calcMinusWith = calcBinRule "minus" (-) isMinus++calcTimesWith :: Num a => String -> View Expr a -> Rule Expr+calcTimesWith = calcBinRule "times" (*) isTimes++calcDivisionWith :: Integral a => String -> View Expr a -> Rule Expr+calcDivisionWith viewName v =+   makeRule (calcRuleName "division" viewName) $ \e ->+   do (e1, e2) <- isDivide e+      a <- match v e1+      b <- match v e2+      let (d, m) = divMod a b+      guard (b /= 0 && m == 0)+      return (build v d)++negateZero :: Rule Expr+negateZero = makeRule (alg, "negate-zero") f+ where+   f (Negate (Nat n)) | n == 0 = Just 0+   f _                         = Nothing++doubleNegate :: Rule Expr+doubleNegate = makeRule (alg, "double-negate") f+ where+   f (Negate (Negate a)) = Just a+   f _                   = Nothing++plusNegateLeft :: Rule Expr+plusNegateLeft = makeRule (alg, "plus-negate-left") f+ where+   f (Negate a :+: b) = Just (b :-: a)+   f _                = Nothing++plusNegateRight :: Rule Expr+plusNegateRight = makeRule (alg, "plus-negate-right") f+ where+   f (a :+: Negate b) = Just (a :-: b)+   f _                = Nothing++minusNegateLeft :: Rule Expr+minusNegateLeft = makeRule (alg, "minus-negate-left") f+ where+   f (Negate a :-: b) = Just (Negate (a :+: b))+   f _                = Nothing++minusNegateRight :: Rule Expr+minusNegateRight = makeRule (alg, "minus-negate-right") f+ where+   f (a :-: Negate b) = Just (a :+: b)+   f _                = Nothing++timesNegateLeft :: Rule Expr+timesNegateLeft = makeRule (alg, "times-negate-left") f+ where+   f (Negate a :*: b) = Just (Negate (a :*: b))+   f _                = Nothing++timesNegateRight :: Rule Expr+timesNegateRight = makeRule (alg, "times-negate-right") f+ where+   f (a :*: Negate b) = Just (Negate (a :*: b))+   f _                = Nothing++divisionNegateLeft :: Rule Expr+divisionNegateLeft = makeRule (alg, "division-negate-left") f+ where+   f (Negate a :/: b) = Just (Negate (a :/: b))+   f _                = Nothing++divisionNegateRight :: Rule Expr+divisionNegateRight = makeRule (alg, "division-negate-right") f+ where+   f (a :/: Negate b) = Just (Negate (a :/: b))+   f _                = Nothing++divisionNumerator :: Rule Expr+divisionNumerator = makeRule (alg, "division-numerator") f+ where+   f ((a :/: b) :/: c)        = Just (a :/: (b :*: c))+   f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c)))+   f _                        = Nothing++divisionDenominator :: Rule Expr+divisionDenominator = makeRule (alg, "division-denominator") f+ where+   f (a :/: (b :/: c))        = Just ((a :*: c) :/: b)+   f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b))+   f _                        = Nothing++simplerFraction :: Rule Expr+simplerFraction = makeRule (alg, "simpler-fraction") $ \expr -> do+   new <- canonical rationalRelaxedForm expr+   guard (expr /= new)+   return new++fractionPlus :: Rule Expr -- also minus+fractionPlus = makeRule (alg, "fraction-plus") $ \expr -> do+   (e1, e2) <- match plusView expr+   (a, b)   <- match fractionForm e1+   (c, d)   <- match fractionForm e2+   guard (b == d)+   return (build fractionForm (a+c, b))++fractionPlusScale :: Rule Expr -- also minus+fractionPlusScale = makeRule (alg, "fraction-plus-scale") $ \expr -> do+   (e1, e2) <- matchM plusView expr+   (a, b)   <- matchM fractionForm e1 <|> fmap (\n -> (n, 1)) (matchM integerNF e1)+   (c, d)   <- matchM fractionForm e2 <|> fmap (\n -> (n, 1)) (matchM integerNF e2)+   guard (b /= 0 && d /= 0 && b /= d)+   let bd  = lcm b d+       e1n = build fractionForm (a * (bd `div` b), bd)+       e2n = build fractionForm (c * (bd `div` d), bd)+   [ build plusView (e1n, e2) | b /= bd ] ++ [+     build plusView (e1, e2n) | d /= bd ]++fractionTimes :: Rule Expr+fractionTimes = makeRule (alg, "fraction-times") f+ where+   f (e1 :*: e2) = do+      (a, b)   <- matchM fractionForm e1 <|> fmap (\n -> (n, 1)) (matchM integerNF e1)+      (c, d)   <- matchM fractionForm e2 <|> fmap (\n -> (n, 1)) (matchM integerNF e2)+      return (build fractionForm (a*c, b*d))+   f _ = Nothing++fractionTimesCancelNomDen :: Rule Expr+fractionTimesCancelNomDen = makeRule (alg, "fraction-times-cancel-denominator-nominator") f+ where+   f (e1 :*: e2) = do+      (a, b)   <- matchM fractionForm e1 <|> fmap (\n -> (n, 1)) (matchM integerNF e1)+      (c, d)   <- matchM fractionForm e2 <|> fmap (\n -> (n, 1)) (matchM integerNF e2)+      guard (a==d)+      return (build fractionForm (c, b))+   f _ = Nothing++fractionTimesCancelDenNom :: Rule Expr+fractionTimesCancelDenNom = makeRule (alg, "fraction-times-cancel-nominator-denominator") f+ where+   f (e1 :*: e2) = do+      (a, b)   <- matchM fractionForm e1 <|> fmap (\n -> (n, 1)) (matchM integerNF e1)+      (c, d)   <- matchM fractionForm e2 <|> fmap (\n -> (n, 1)) (matchM integerNF e2)+      guard (b==c)+      return (build fractionForm (a, d))+   f _ = Nothing
+ src/Domain/Math/Polynomial/Balance.hs view
@@ -0,0 +1,294 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Polynomial.Balance where++import Control.Monad+import Data.Function+import Data.Maybe+import Data.Ratio+import Data.Semigroup+import Domain.Math.Data.Relation+import Domain.Math.Data.WithBool+import Domain.Math.Equation.BalanceRules+import Domain.Math.Equation.Views+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.BalanceUtils+import Domain.Math.Polynomial.BuggyBalance+import Domain.Math.Polynomial.Examples+import Domain.Math.Polynomial.Generators+import Domain.Math.Polynomial.Rules        (conditionVarsRHS, flipEquation)+import Domain.Math.Polynomial.Views+import Ideas.Common.Examples+import Ideas.Common.Library                hiding ((.*.))+import Ideas.Common.Strategy.Legacy+import Ideas.Utils.Prelude                 (fixpoint)+import Ideas.Utils.Uniplate+import Prelude                             hiding ((<*>))+import Test.QuickCheck                     (sized)++------------------------------------------------------------+-- Exercise++balanceExercise :: Exercise (WithBool (Equation Expr))+balanceExercise = makeExercise+   { exerciseId    = describe "Solve a linear equation using only balance rules." $+                     newId "algebra.equations.linear.balance"+   , status        = Provisional+   , parser        = parseBoolEqExpr+   , similarity    = withoutContext ((==) `on` cleaner)+   , equivalence   = withoutContext (viewEquivalent eqView)+   , suitable      = predicateView (traverseView linearEquationView)+   , ready         = predicateView (traverseView (equationSolvedWith mixedFractionNF))+                     <||> predicateView (traverseView (equationSolvedWith rationalNF))+                     <||> predicateView (traverseView (equationSolvedWith doubleNF))+   , strategy      = balanceStrategy+   , extraRules    = map use buggyBalanceRules ++ map use buggyBalanceExprRules+   , ruleOrdering  = ruleOrderingWith (balanceOrder ++ buggyPriority)+   , navigation    = termNavigator+   , examples      = fmap singleton linearExamples+                     <> forTesting (random (liftM2 (\a b -> singleton (a :==: b)) (sized linearGen) (sized linearGen)))+   }++balanceOrder :: [Id]+balanceOrder =+   [ getId introTrue, getId introFalse+   , getId removeDivision, getId collect+   , getId varRightMinus, getId varRightPlus+   , getId conLeftMinus, getId conLeftPlus+   , getId varLeftMinus, getId varLeftPlus   -- prefer variable to left+   , getId conRightMinus, getId conRightPlus -- or constant to right+   , getId scaleToOne, getId flipEquation+   , getId divideCommonFactor, getId distribute+   , getId collect, getId divisionToFraction+   , getId negateBothSides+   ]++------------------------------------------------------------+-- Strategy++balanceStrategy :: LabeledStrategy (Context (WithBool (Equation Expr)))+balanceStrategy = cleanUpStrategyAfter (applyTop cleaner) $+   label "Balance equation" $+       label "Phase 1" (repeatS+           (  use collect+          <|> use distribute+          <|> use removeDivision+          <|> somewhere (use divisionToFraction)+          <|> use negateBothSides+          <|> use introTrue <|> use introFalse+           ))+   <*> label "Phase 2" (repeatS+           (  use varLeftMinus <|> use varLeftPlus+          <|> use conRightMinus <|> use conRightPlus+          <|> use introTrue <|> use introFalse+          <|> atomic (check p2 <*> (use varRightMinus <|> use varRightPlus))+          <|> atomic (check p1 <*> (use conLeftMinus <|> use conLeftPlus))+           )+       <*> try (use scaleToOne)+       <*> try (use calculate))+       -- flip sides of an equation (at most once)+   <%> try (atomic (use (check conditionVarsRHS) <*> use flipEquation))+       -- divide by a common factor (but not as final "scale-to-one" step)+   <%> many (atomic (notS (use scaleToOne) <*> use divideCommonFactor))+   -- <%> many (use introTrue <|> use introFalse)+ where+   -- move constants to left only if there are no variables on the left+   p1 = maybe False (either (const False) (hasNoVar . leftHandSide) . fromWithBool) . fromContext+   p2 ceq = fromMaybe False $ do+      wb           <- fromContext ceq+      lhs :==: rhs <- either (const Nothing) Just (fromWithBool wb)+      (x1, a, c)   <- matchLin lhs+      (x2, b, _)   <- matchLin rhs+      return (x1 == x2 && b > a && a /= 0 && c /= 0)++------------------------------------------------------------+-- Rules++calculate :: Rule (WithBool (Equation Expr))+calculate = makeRule (linbal, "calculate") $ checkForChange $+   Just . cleaner++-- factor is always positive due to lcm function+removeDivision :: Rule (Equation Expr)+removeDivision = doAfter (fmap distributeTimes) $+   describe "remove division" $+   ruleTrans (linbal, "remove-div") $+   inputWith removeDivisionArg timesRule+ where+   removeDivisionArg = makeTrans $ \(lhs :==: rhs) -> do+      xs <- match simpleSumView lhs+      ys <- match simpleSumView rhs+      -- also consider parts without variables+      -- (but at least one participant should have a variable)+      zs <- mapM getFactor (xs++ys)+      let (b, result) = foldr op (False, 1) zs+          op (b1, a1) (b2, a2) = (b1 || b2, a1 `lcm` a2)+      guard (b && result > 1)+      return (fromInteger result)++   getFactor (Negate a) = getFactor a+   getFactor expr = do+      (b, c) <- match (divView >>> second integerView) expr+      return (hasSomeVar b, c)+    `mplus` do+      r <- match rationalView expr+      return (False, denominator r)+    `mplus` do+      (r, c) <- match (timesView >>> first rationalView) expr+      return (hasSomeVar c, denominator r)+    `mplus` do+      (b, r) <- match (timesView >>> second rationalView) expr+      return (hasSomeVar b, denominator r)+    `mplus` do+      (_, ps) <- match simpleProductView expr+      guard (any (`belongsTo` rationalView) ps)+      return (False, 1)+    `mplus` do+      guard (isVariable expr)+      return (False, 1)++divisionToFraction :: Rule Expr+divisionToFraction =+   describe "turn a division into a multiplication with a fraction" $+   makeRule (linbal, "div-to-fraction") $ \expr -> do+      (a, r) <- match (divView >>> second rationalView) expr+      guard (hasSomeVar a && r /= 0)+      return (fromRational (1/r)*a)++divideCommonFactor :: Rule (Equation Expr)+divideCommonFactor = doAfter (fmap distributeDiv) $+   describe "divide by common factor" $+   ruleTrans (linbal, "smart-div") $+   inputWith (transMaybe getArg) divisionRule+ where+   getArg (lhs :==: rhs)+      | null xs                 = fail "no factor"+      | 0 `notElem` ns && n > 1 = return (fromInteger n)+      | otherwise               = fail "no factor"+    where+       xs = from simpleSumView lhs ++ from simpleSumView rhs+       ns = map getFactor xs+       n  = foldr1 gcd ns++   getFactor expr+      | hasNoVar expr = fromMaybe 1 $ match integerView expr+      | otherwise = fromMaybe 1 $ do+           (a, b) <- match timesView expr+           case (match integerView a, match integerView b) of+              (Just n, _) | hasSomeVar b -> return n+              (_, Just n) | hasSomeVar a -> return n+              _ -> Nothing++negateBothSides :: Rule (Equation Expr)+negateBothSides = describe "Remove negation on both sides of an equation" $+   rewriteRule (linbal, "negate") $ \a b ->+      (-a :==: -b) :~> (a :==: b)++varLeftMinus, varLeftPlus :: Rule (Equation Expr)+varLeftMinus = varLeft True  (linbal, "var-left-minus")+varLeftPlus  = varLeft False (linbal, "var-left-plus")++varLeft :: IsId a => Bool -> a -> Rule (Equation Expr)+varLeft useMinus rid = doAfter (fmap collectLocal) $+   ruleTrans rid $+   inputWith varLeftArg (if useMinus then minusRule else plusRule)+ where+    varLeftArg = transMaybe $ \(lhs :==: rhs) -> do+       guard (hasSomeVar lhs)+       (x, a, _) <- matchLin rhs+       guard (if useMinus then a > 0 else a < 0)+       return (fromRational (abs a) .*. x)++conRightMinus, conRightPlus :: Rule (Equation Expr)+conRightMinus = conRight True  (linbal, "con-right-minus")+conRightPlus  = conRight False (linbal, "con-right-plus")++conRight :: IsId a => Bool -> a -> Rule (Equation Expr)+conRight useMinus rid = doAfter (fmap collectLocal) $+   ruleTrans rid $+   inputWith conRightArg (if useMinus then minusRule else plusRule)+ where+    conRightArg = transMaybe $ \(lhs :==: _) -> do+       guard (hasSomeVar lhs)+       (_, _, b) <- matchLin lhs+       guard (if useMinus then b > 0 else b < 0)+       return (fromRational (abs b))++varRightMinus, varRightPlus :: Rule (Equation Expr)+varRightMinus = flipped (linbal, "var-right-minus") varLeftMinus+varRightPlus  = flipped (linbal, "var-right-plus")  varLeftPlus++conLeftMinus, conLeftPlus :: Rule (Equation Expr)+conLeftMinus = flipped (linbal, "con-left-minus") conRightMinus+conLeftPlus  = flipped (linbal, "con-left-plus")  conRightPlus++flipped :: IsId a => a -> Rule (Equation b) -> Rule (Equation b)+flipped rid = liftView flipView . changeId (const (newId rid))+ where+   flipView = makeView (Just . flipSides) flipSides++scaleToOne :: Rule (Equation Expr)+scaleToOne = doAfter (fmap distributeDiv) $+   ruleTrans (linbal, "scale-to-one") $+   inputWith scaleToOneArg divisionRule+ where+   scaleToOneArg = transMaybe $ \(lhs :==: rhs) -> f lhs rhs `mplus` f rhs lhs++   f :: Expr -> Expr -> Maybe Expr+   f expr c = do+      (_, a1, b1) <- matchLin expr+      guard (a1 /= 0 && a1 /= 1 && b1 == 0 && hasNoVar c)+      return (fromRational a1)++collect :: Rule (Equation Expr)+collect = makeRule (linbal, "collect") $+   -- don't use this rule just for cleaning up+   checkForChange (Just . fmap collectGlobal) . fmap cleanerExpr++distribute :: Rule (Equation Expr)+distribute = makeRule (linbal, "distribute") $ checkForChange $+   Just . fmap (fixpoint f)+ where+   f (a :*: (b :+: c))  = f (a*b + a*c)+   f (a :*: (b :-: c))  = f (a*b - a*c)+   f ((a :+: b) :*: c)  = f (a*c + b*c)+   f ((a :-: b) :*: c)  = f (a*c - b*c)+   f (Negate (a :+: b)) = f (-a-b)+   f (Negate (a :-: b)) = f (-a+b)+   f (Negate (Negate a)) = f a+   f (a :-: (b :+: c)) = f (a-b-c)+   f (a :-: (b :-: c)) = f (a-b+c)+   f (a :-: Negate b)  = f (a+b)+   f a = descend f a++introTrue :: Rule (WithBool (Equation Expr))+introTrue = makeRule (linbal, "intro-true") $ f . fromWithBool . cleaner+ where+   f (Right (lhs :==: rhs)) | lhs == rhs = Just true+   f _ = Nothing++introFalse :: Rule (WithBool (Equation Expr))+introFalse = makeRule (linbal, "intro-false") $ f . fromWithBool . cleaner+ where+   f (Right (lhs :==: rhs)) = do+      x <- match rationalView lhs+      y <- match rationalView rhs+      guard (x /= y)+      return false+   f _ = Nothing++-- for debugging+{-+go = printDerivation balanceExercise $ singleton $ let x=Var "x" in+   (x+2+7/2*x)/(3/2) :==: -3/2*x/4*0 -}
+ src/Domain/Math/Polynomial/BalanceUtils.hs view
@@ -0,0 +1,247 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Domain.Math.Polynomial.BalanceUtils+   ( eqView, minusView, negView+   , matchLin, matchPlusCon+   , cleaner, cleanerExpr+   , linbal, checkForChange+   , termRef, factorRef, factor1Ref, factor2Ref+   , writeTerm, writeWith+   , buggyBalanceRule, buggyBalanceRuleArg+   , buggyBalanceExprRule+   , buggyBalanceRecognizer+   , collectLocal, collectGlobal+   , distributeDiv, distributeTimes+   , isPlusT, diffPlus+   , isTimesT, diffTimes+   ) where++import Control.Monad+import Data.List+import Data.Maybe+import Domain.Math.Data.Polynomial+import Domain.Math.Data.Relation+import Domain.Math.Data.WithBool+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.Views+import Domain.Math.Safe+import Domain.Math.Simplification   (mergeAlikeSum)+import Ideas.Common.Library+import Ideas.Utils.Prelude          (fixpoint)+import Ideas.Utils.Uniplate++eqView :: View (WithBool (Equation Expr)) (WithBool (String, Rational))+eqView = makeView (either (Just . fromBool) f . fromWithBool) (fmap g)+ where+   f (lhs :==: rhs) = do+      (s, p) <- match (polyViewWith rationalApproxView) (lhs-rhs)+      case degree p of+         0 -> Just $ fromBool $ coefficient 0 p == 0+         1 -> Just $ singleton (s, - coefficient 0 p / coefficient 1 p)+         _ -> Nothing+   g (s, r) = Var s :==: fromRational r++minusView :: View Expr (Expr, Expr)+minusView = makeView isMinus (uncurry (:-:))++negView :: View Expr Expr+negView = makeView isNegate Negate++matchLin :: MonadPlus m => Expr -> m (Expr, Rational, Rational)+matchLin expr = do+   (s, p) <- matchM (polyNormalForm rationalView) expr+   guard (degree p == 1)+   return (Var s, coefficient 1 p, coefficient 0 p)++matchPlusCon :: MonadPlus m => Expr -> m (Expr, Rational)+matchPlusCon expr =+   matchM (plusView >>> second rationalView) expr+ `mplus`+   matchM (plusView >>> toView swapView >>> second rationalView) expr++------------------------------------------------------------+-- Strategy++cleaner :: WithBool (Equation Expr) -> WithBool (Equation Expr)+cleaner = fmap (fmap cleanerExpr)++cleanerExpr :: Expr -> Expr+cleanerExpr = transform f -- no fixpoint is needed+ where+   f (a :/: Nat 1) = f a+   f (a :/: Negate (Nat 1)) = f $ Negate a+   f (Negate a :/: Negate b) = f (a/b)+   f (a :/: Negate b) = f $ Negate (a/b)+   f (Negate a :/: b) = f $ Negate (a/b)+   f (Negate (Negate a)) = f a+   f e = cleanSum (cleanProduct (simplify rationalView e))++   cleanSum =+      let g x y = canonical rationalView (x :+: y)+      in simplifyWith (adjacent g) simpleSumView++   cleanProduct =+      let g x y   = canonical rationalView (x :*: y)+          reorder = uncurry (++) . partition (`belongsTo` rationalView)+      in simplifyWith (mapSecond (adjacent g . reorder)) simpleProductView++adjacent :: (a -> a -> Maybe a) -> [a] -> [a]+adjacent f = rec+ where+   rec (x:y:rest) =+      case f x y of+         Just xy -> rec (xy:rest)+         Nothing -> x:rec (y:rest)+   rec xs = xs++{-+trivial :: Equation Expr -> WithBool (Equation Expr)+trivial eq@(lhs :==: rhs) =+   case (match rationalView lhs, match rationalView rhs) of+      (Just r1, Just r2)+         | r1 == r2                -> true+         | otherwise               -> false+      _  | any nonsense [lhs, rhs] -> false+         | lhs == rhs              -> true+         | otherwise               -> singleton eq++nonsense :: Expr -> Bool+nonsense = any p . universe+ where+   p (_ :/: a) = maybe False (==0) (match rationalView a)+   p _         = False -}++------------------------------------------------------------+-- References++termRef, factorRef, factor1Ref, factor2Ref :: Ref Expr+termRef    = makeRef "term"+factorRef  = makeRef "factor"+factor1Ref = makeRef "factor1"+factor2Ref = makeRef "factor2"++writeWith :: Trans c () -> (a -> Maybe (b, c)) -> Trans a b+writeWith wf f = transMaybe f >>> second wf >>> arr fst++writeTerm :: (a -> Maybe (b, Expr)) -> Trans a b+writeTerm = writeWith (writeRef_ termRef)++------------------------------------------------------------+-- Rules++linbal :: Id+linbal = newId "algebra.equations.linear.balance"++bugbal :: IsId n => n -> Id+bugbal n = newId (linbal, "buggy", n)++checkForChange :: (MonadPlus m, Eq a) => (a -> m a) -> a -> m a+checkForChange f a = f a >>= \b -> guard (a /= b) >> return b++buggyBalanceRule :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr)) -> Rule (Equation Expr)+buggyBalanceRule n = addTransRecognizer eq . buggyRule (bugbal n)+ where+   eq = viewEquivalent (traverseView (polyViewWith rationalView))++buggyBalanceRuleArg :: IsId n => n -> Trans (Equation Expr) (Equation Expr) -> Rule (Equation Expr)+buggyBalanceRuleArg n = addTransRecognizer eq . buggy . ruleTrans (bugbal n)+ where+   eq = viewEquivalent (traverseView (polyViewWith rationalView))++buggyBalanceExprRule :: IsId n => n -> (Expr -> Maybe Expr) -> Rule Expr+buggyBalanceExprRule = buggyRule . bugbal++buggyBalanceRecognizer :: IsId n => n -> Trans (a, a) () -> Rule a+buggyBalanceRecognizer n t =+   addRecognizer (makeRecognizerTrans t)  $ buggy $ emptyRule (bugbal n)++------------------------------------------------------------+-- Helpers++collectLocal :: Expr -> Expr+collectLocal = simplifyWith (mapSecond f) simpleProductView+             . simplifyWith mergeAlikeSum simpleSumView+ where+   f xs | length ys > 1 = ys++zs+        | otherwise     = xs+    where+      (ys, zs) = partition hasNoVar xs++collectGlobal :: Expr -> Expr+collectGlobal = fixpoint (transform collectLocal)++distributeDiv :: Expr -> Expr+distributeDiv expr = fromMaybe expr $ do+   (a, r) <- match (divView >>> second rationalView) expr+   return $ simplifyWith (fmap (`divide` r)) simpleSumView a+ where+   divide x r = fromMaybe (x/fromRational r) $ do+      (y, z) <- match (timesView >>> first rationalView) x+      new    <- y `safeDiv` r+      return (fromRational new * z)+    `mplus` do+      (y, z) <- match (timesView >>> second rationalView) x+      new    <- z `safeDiv` r+      return (y * fromRational new)++distributeTimes :: Expr -> Expr+distributeTimes expr = fromMaybe expr $ do+   (r, a) <- match (timesView >>> first rationalView) expr+              `mplus`+             match (timesView >>> second rationalView >>> toView swapView) expr+   return $ simplifyWith (fmap (times r)) simpleSumView a+ where+   times r x = fromMaybe (fromRational r*x) $ do+      (a, b) <- match (divView >>> second rationalView) x+      guard (b /= 0)+      return (fromRational (r/b) * a)++isPlusT :: Equation Expr -> Equation Expr -> Bool+isPlusT old new = isJust (diffPlusEq old new)++diffPlusEq :: Equation Expr -> Equation Expr -> Maybe Expr+diffPlusEq (a1 :==: a2) (b1 :==: b2) = do+   d1 <- diffPlus a1 b1+   d2 <- diffPlus a2 b2+   guard (d1 == d2)+   return d1++diffPlus :: Expr -> Expr -> Maybe Expr+diffPlus a b = do+   let myView = polyViewWith rationalView+   (x, pa) <- matchM myView a+   (y, pb) <- matchM myView b+   guard (x==y)+   let d = pb - pa+   return $ build myView (x, d)++isTimesT :: Equation Expr -> Equation Expr -> Bool+isTimesT old new = isJust (diffTimesEq old new)++diffTimesEq :: Equation Expr -> Equation Expr -> Maybe Expr+diffTimesEq (a1 :==: a2) (b1 :==: b2) = do+   d1 <- diffTimes a1 b1+   d2 <- diffTimes a2 b2+   guard (d1 == d2)+   return d1++diffTimes :: MonadPlus m => Expr -> Expr -> m Expr+diffTimes a b = do+   let myView = polyViewWith rationalView+   (x, pa) <- matchM myView a+   (y, pb) <- matchM myView b+   guard (x==y)+   if pa==0 && pb==0 then return 1 else do+    d <- maybe (fail "diffTimes") return (pb `safeDiv` pa)+    return $ build myView (x, d)
+ src/Domain/Math/Polynomial/BuggyBalance.hs view
@@ -0,0 +1,535 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.BuggyBalance
+   ( buggyBalanceRules, buggyBalanceExprRules, buggyPriority
+   ) where
+
+import Control.Monad
+import Data.Ratio
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.BalanceUtils
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+
+buggyBalanceRules :: [Rule (Equation Expr)]
+buggyBalanceRules =
+   [ rule1234, rule201, rule2111, rule2112, rule2113, rule2114
+   , rule2121, rule2122, rule2131, rule2132, rule2133, rule2134
+   , rule2135, rule2136, rule2137, rule2138, rule2141, rule2142
+   , rule221, rule222, rule2232, rule2233
+   , rule311, rule322, rule2231, rule227, rule321, rule323
+   ]
+
+buggyBalanceExprRules :: [Rule Expr]
+buggyBalanceExprRules =
+   [ rule121, rule122, rule1231, rule1232, rule1311, rule1312
+   , rule1314, rule1321, rule1322, rule133, rule134, rule135
+   , rule136, rule137
+   ]
+
+buggyPriority :: [Id]
+buggyPriority =
+   [ getId rule1312, getId rule121, getId rule221, getId rule222
+   , getId rule2232, getId rule2233, getId rule227, getId rule323
+   ]
+
+-------------------------------------------------------------------
+-- 1.2 Fout bij vermenigvuldigen
+
+-- (a*b)/c  ->  a/(b*c)
+rule121 :: Rule Expr
+rule121 = describe "1.2.1: fout bij vermenigvuldigen" $
+   buggyBalanceExprRule "multiply1" f
+ where
+   f (expr :/: c) = do
+      (a, b) <- match timesView expr
+      return $ a/(b*c)
+   f _ = Nothing
+
+-- a*(bx+c)  ->  x/(ab) + ac
+rule122 :: Rule Expr
+rule122 = describe "1.2.2: fout bij vermenigvuldigen" $
+   buggyBalanceExprRule "multiply2" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ x/(a*b) + a*c
+   f _ = Nothing
+
+-- a(b-cx)  -> ab+acx
+rule1231 :: Rule Expr
+rule1231 = describe "1.2.3.1: fout bij vermenigvuldigen; min raakt kwijt" $
+   buggyBalanceExprRule "multiply3" f
+ where
+   f (a :*: expr) = do
+      (b, (c, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b+a*c*x
+   f _ = Nothing
+
+-- -a*(x-b)  -> -ax-ab
+rule1232 :: Rule Expr
+rule1232 = describe "1.2.3.2: fout bij vermenigvuldigen; min te veel" $
+   buggyBalanceExprRule "multiply4" f
+ where
+   f expr = do
+      (a, (x, b)) <- match (timesView >>> negView *** minusView) expr
+      return $ -a*x-a*b
+
+-- -ax=b  ->  x=b/a
+rule1234 :: Rule (Equation Expr)
+rule1234 = describe "1.2.3.4: fout bij vermenigvuldigen; delen door negatief getal" $
+   buggyBalanceRule "multiply5" f
+ where
+   f (expr :==: b) = do
+      (a, x) <- match (timesView >>> first negView) expr
+      return $ x :==: b/a
+
+-------------------------------------------------------------------
+-- 1.3 Fout bij haakjes wegwerken
+
+-- a(x-b)  ->  ax-b    (verruimt naar +)
+rule1311 :: Rule Expr
+rule1311 = describe "1.3.1.1: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par1" f
+ where
+   f expr = do
+      (a, (x, b)) <- match (timesView >>> second plusView) expr
+      return $ a*x+b
+
+-- 1/a*(x-b)  -> 1/a*x-b   (specialized version of par1)
+rule1312 :: Rule Expr
+rule1312 = describe "1.3.1.2: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par2" f
+ where
+   f (e1 :*: e2) = do
+      (n, a) <- match (divView >>> first integerView) e1
+      guard (n==1)
+      (x, b) <- match plusView e2
+      return $ 1/a*x+b
+   f _ = Nothing
+
+-- a(b-cx)  -> ab-cx
+{- zie par1
+rule1313 :: Rule (Equation Expr)
+rule1313 = describe "1.3.1.3: fout bij haakjes wegwerken; haakjes staan e
+r niet voor niets" $
+
+   buggyBalanceExprRule "par3") f
+ where
+   f (a :*: expr) = do
+      (b, (c, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b-c*x
+   f _ = Nothing -}
+
+-- -(a+b)  ->  -a+b
+rule1314 :: Rule Expr
+rule1314 = describe "1.3.1.4: fout bij haakjes wegwerken met unaire min; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par11" f
+ where
+   f expr = do
+      (a, b) <- match (negView >>> plusView) expr
+      return $ -a+b
+
+-- a(bx+c)  ->  ax+ac
+rule1321 :: Rule Expr
+rule1321 = describe "1.3.2.1: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par4" f
+ where
+   f (a :*: expr) = do
+      ((_, x), c) <- match (plusView >>> first timesView) expr
+      return $ a*x+a*c
+   f _ = Nothing
+
+-- a(b-cx)  -> ab-ax
+rule1322 :: Rule Expr
+rule1322 = describe "1.3.2.2: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par5" f
+ where
+   f (a :*: expr) = do
+      (b, (_, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b-a*x
+   f _ = Nothing
+
+-- a(bx+c)  -> bx+ac
+rule133 :: Rule Expr
+rule133 = describe "1.3.3: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par6" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ b*x+a*c
+   f _ = Nothing
+
+-- a-(b+c)  -> a-b+c
+rule134 :: Rule Expr
+rule134 = describe "1.3.4: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par7" f
+ where
+   f expr = do
+      (a, (b, c)) <- match (minusView >>> second plusView) expr
+      return $ a-b+c
+
+-- a*(b-c)-d  ->  ab-ac-ad
+rule135 :: Rule Expr
+rule135 = describe "1.3.5: fout bij haakjes wegwerken; kijk goed waar de haakjes staan" $
+   buggyBalanceExprRule "par8" f
+ where
+   f expr = do
+      ((a, (b, c)), d) <- match (minusView >>> first (timesView >>> second minusView)) expr
+      return $ a*b-a*c-a*d
+
+--  a(bx+c)  ->  (a+b)x+ac
+rule136 :: Rule Expr
+rule136 = describe "1.3.6: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par9" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ (a+b)*x+a*c
+   f _ = Nothing
+
+-- a+b(x-c)  -> (a+b)(x-c)
+rule137 :: Rule Expr
+rule137 = describe "1.3.7: fout bij haakjes wegwerken; denk aan 'voorrangsregels'" $
+   buggyBalanceExprRule "par10" f
+ where
+   f (a :+: expr) = do
+      (b, (x, c)) <- match (timesView >>> second plusView) expr
+      return $ (a+b)*(x+c)
+   f _ = Nothing
+
+-------------------------------------------------------------------
+-- 2.0 Links en rechts hetzelfde doen, of verwisselen
+
+-- a=b-c  ->  c-b=a
+rule201 :: Rule (Equation Expr)
+rule201 = describe "2.0.1: Links en rechts alleen maar verwisseld?" $
+   buggyBalanceRule "flip1" f
+ where
+   f (a :==: rhs) = do
+      (b, c) <- match minusView rhs
+      return $ c-b :==: a
+
+-------------------------------------------------------------------
+-- 2.1 Links en rechts hetzelfde optellen/aftrekken
+
+{-
+
+   schema addbal regels: (telkens paren met positief/negatief argument)
+   1+2   constante naar rechts
+   3+4   variabele naar links
+   7+8   variabele naar rechts
+   9+10  constante naar links
+   ---
+   5/6    constante links  weggehaald, maar rechts onveranderd gelaten
+   11/12  constante rechts weggehaald, maar links  onveranderd gelaten
+   13/14  variabele links  weggehaald, maar rechts onveranderd gelaten
+   15/16  variabele rechts weggehaald, maar links  onveranderd gelaten
+-}
+
+-- ax+b=[cx]+d  -> ax=[cx]+d+b
+rule2111 :: Rule (Equation Expr)
+rule2111 = describe "2.1.1.1: Links en rechts hetzelfde optellen; links +b en rechts -b" $
+   buggyBalanceRuleArg "addbal1" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b>0)
+      return (ax :==: rhs+fromRational b, fromRational b)
+
+-- ax-b=[cx]+d  -> ax=[cx+d-b
+rule2112 :: Rule (Equation Expr)
+rule2112 = describe "2.1.1.2: Links en rechts hetzelfde optellen; links -b en rechts +b" $
+   buggyBalanceRuleArg "addbal2" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b<0)
+      return (ax :==: rhs+fromRational b, fromRational (abs b))
+
+-- a=cx+d  -> a+d=cx
+rule2113 :: Rule (Equation Expr)
+rule2113 = describe "2.1.1.3: Je trekt er rechts {?} vanaf, maar links tel je {?} erbij op." $
+   buggyBalanceRuleArg "addbal9" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(cx, d) <- matchPlusCon rhs
+      guard (d>0)
+      return (lhs+fromRational d :==: cx, fromRational d)
+
+-- a=cx-d  -> a-d=cx
+rule2114 :: Rule (Equation Expr)
+rule2114 = describe "2.1.1.4: Je telt er rechts {?} bij op, maar links trek je {?} er vanaf." $
+   buggyBalanceRuleArg "addbal10" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(cx, d) <- matchPlusCon rhs
+      guard (d<0)
+      return (lhs+fromRational d :==: cx, fromRational (abs d))
+
+-- ax[+b]=cx+d  ->  (a+c)x[+b]=d
+rule2121 :: Rule (Equation Expr)
+rule2121 = describe "2.1.2.1: Links en rechts hetzelfde optellen; links +cx en rechts -cx" $
+   buggyBalanceRuleArg "addbal3" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (c>0 && x==y)
+      return (fromRational (a+c)*x+fromRational b :==: fromRational d, fromRational c*x)
+
+-- ax[+b]=-cx+d  -> (a-c)x[+b]=d
+rule2122 :: Rule (Equation Expr)
+rule2122 = describe "2.1.2.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
+   buggyBalanceRuleArg "addbal4" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (c<0 && x==y)
+      return (fromRational (a+c)*x+fromRational b :==: fromRational d, fromRational (abs c)*x)
+
+-- ax+b=cx+d  ->  b=(a+c)*x+d
+rule2141 :: Rule (Equation Expr)
+rule2141 = describe "2.1.4.1: Links en rechts hetzelfde optellen; links -ax en rechts +ax" $
+   buggyBalanceRuleArg "addbal7" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (a>0 && x==y)
+      return (fromRational b :==: fromRational (a+c)*x+fromRational d, fromRational a*x)
+
+-- -ax+b=cx+d  ->  b=(-a+c)*x+d
+rule2142 :: Rule (Equation Expr)
+rule2142 = describe "2.1.4.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
+   buggyBalanceRuleArg "addbal8" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (a<0 && x==y)
+      return (fromRational b :==: fromRational (a+c)*x+fromRational d, fromRational (abs a)*x)
+
+-- ax+b=e  -> ax=e
+rule2131 :: Rule (Equation Expr)
+rule2131 = describe "2.1.3.1: Links en rechts hetzelfde optellen; links -b rechts niet(s)" $
+   buggyBalanceRuleArg "addbal5" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b > 0)
+      return (ax :==: rhs, fromRational b)
+
+-- ax-b=e  -> ax=e
+rule2132 :: Rule (Equation Expr)
+rule2132 = describe "2.1.3.2: Links en rechts hetzelfde optellen; links +b en rechts niet(s)" $
+   buggyBalanceRuleArg "addbal6" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b < 0)
+      return (ax :==: rhs, fromRational (abs b))
+
+-- e=ax+b  -> e=ax
+rule2133 :: Rule (Equation Expr)
+rule2133 = describe "2.1.3.3: Links en rechts hetzelfde optellen; rechts -b links niet(s)" $
+   buggyBalanceRuleArg "addbal11" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon rhs
+      guard (b > 0)
+      return (lhs :==: ax, fromRational b)
+
+-- e=ax-b  -> e=ax
+rule2134 :: Rule (Equation Expr)
+rule2134 = describe "2.1.3.4: Links en rechts hetzelfde optellen; rechts +b en links niet(s)" $
+   buggyBalanceRuleArg "addbal12" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon rhs
+      guard (b < 0)
+      return (lhs :==: ax, fromRational (abs b))
+
+-- ax+b=e  -> b=e
+rule2135 :: Rule (Equation Expr)
+rule2135 = describe "2.1.3.5: Links en rechts hetzelfde optellen; links -ax rechts niet(s)" $
+   buggyBalanceRuleArg "addbal13" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      guard (a > 0)
+      return (fromRational b :==: rhs, fromRational a*x)
+
+-- -ax+b=e  -> b=e
+rule2136 :: Rule (Equation Expr)
+rule2136 = describe "2.1.3.6: Links en rechts hetzelfde optellen; links +ax en rechts niet(s)" $
+   buggyBalanceRuleArg "addbal14" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      guard (a < 0)
+      return (fromRational b :==: rhs, fromRational (abs a)*x)
+
+-- e=ax+b  -> e=b
+rule2137 :: Rule (Equation Expr)
+rule2137 = describe "2.1.3.7: Links en rechts hetzelfde optellen; rechts -ax links niet(s)" $
+   buggyBalanceRuleArg "addbal15" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin rhs
+      guard (a > 0)
+      return (lhs :==: fromRational b, fromRational a*x)
+
+-- e=-ax+b  -> e=b
+rule2138 :: Rule (Equation Expr)
+rule2138 = describe "2.1.3.8: Links en rechts hetzelfde optellen; rechts +ax en links niet(s)" $
+   buggyBalanceRuleArg "addbal16" (writeTerm f)
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin rhs
+      guard (a < 0)
+      return (lhs :==: fromRational b, fromRational (abs a)*x)
+
+-------------------------------------------------------------------
+-- 2.2 Links en rechts hetzelfde vermenigvuldigen/delen
+
+-- ax=c  -> x=a/c
+rule221 :: Rule (Equation Expr)
+rule221 = describe "2.2.1: Links en rechts hetzelfde vermenigvuldigen; verkeerd om gedeeld" $
+   buggyBalanceRule "mulbal1" f
+ where
+   f (expr :==: c) = do
+      (a, x) <- match timesView expr
+      return $ x :==: a/c
+
+-- 1/*a+b=2/c*x+d  -> x+ba  -> 2x+cd
+rule222 :: Rule (Equation Expr)
+rule222 = describe "2.2.2: Links en rechts hetzelfde vermenigvuldigen; links *a; rechts *b" $
+   buggyBalanceRuleArg "mulbal2" t
+ where
+   t = writeWith (writeRef2_ factor1Ref factor2Ref) f
+   f ~(lhs :==: rhs) = do
+      ~(x, ra, b) <- matchLin lhs
+      ~(y, rc, d) <- matchLin rhs
+      let a = denom ra
+          c = denom rc
+          denom = fromInteger . denominator
+          num   = fromInteger . numerator
+      guard (a /= c && (a /= 1 || c /= 1))
+      return (num ra*x+fromRational b*a :==: num rc*y+c*fromRational d, (a, c))
+
+-- ax-b=cx+d  -> pax-pb=cx+d
+rule2231 :: Rule (Equation Expr)
+rule2231 = describe "2.2.3.1: Links en rechts hetzelfde vermenigvuldigen; links *p, rechts niet (of andersom)" $
+   buggyBalanceRecognizer "mulbal3" t
+ where -- currently, symmetric
+   t = transMaybe (uncurry p) >>> writeRef_ factorRef
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      dl <- diffTimes a1 b1
+      dr <- diffTimes a2 b2
+      guard ((dl==1) /=  (dr==1)) -- xor; only one of dl/dr equals 1
+      return (if dr/=1 then dr else dl)
+
+-- (x+a)/b=c  -> x+a=c
+rule2232 :: Rule (Equation Expr)
+rule2232 = describe "2.2.3.2: Links en rechts hetzelfde vermenigvuldigen; links /p, rechts niet" $
+   buggyBalanceRuleArg "mulbal4" t
+ where
+   t = writeWith (writeRef_ factorRef) f
+   f ~(expr :==: c) = do
+      ~(a, b) <- matchM divView expr
+      return (a :==: c, b)
+
+-- a+b=c  -> -a-b=c
+rule2233 :: Rule (Equation Expr)
+rule2233 = describe "2.2.3.3: Links en rechts hetzelfde vermenigvuldigen; links en rechts *-1" $
+   buggyBalanceRule "mulbal5" f
+ where
+   f (expr :==: c) = do
+      (a, b) <- match plusView expr
+      return $ -a-b :==: c
+
+-- pa+pb=c -> a+b=c
+rule227 :: Rule (Equation Expr)
+rule227 = describe "2.2.7: Links en rechts hetzelfde vermenigvuldigen; een kant door p delen, andere kant niets" $
+   buggyBalanceRecognizer "mulbal6" t
+ where -- currently, symmetric
+   t = transMaybe (uncurry p) >>> writeRef_ factorRef
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      dl <- diffTimes a1 b1
+      dr <- diffTimes a2 b2
+      rl <- matchM rationalView dl
+      rr <- matchM rationalView dr
+      guard ( rl == 1 && rr /= 1 && numerator rr == 1 ||
+              rl /= 1 && rr == 1 && numerator rl == 1 )
+      return (fromIntegral (denominator (if rr /= 1 then rr else rl)))
+
+-------------------------------------------------------------------
+-- 3.1 Doe je wat je wilt doen?
+
+-- ax-b=cx-d  -> (c-a)x-b=-d
+rule311 :: Rule (Equation Expr)
+rule311 = describe "3.1.1: Doe je wat je wilt doen?" $
+   buggyBalanceRule "misc1" f
+ where
+   f (lhs :==: rhs) = do
+      (x, a, b) <- matchLin lhs
+      (y, c, d) <- matchLin rhs
+      guard (x==y)
+      return (fromRational (c-a)*x+fromRational b :==: fromRational d)
+
+-- ax-b=cd+d  -> pax-b=pcx+pd
+rule321 :: Rule (Equation Expr)
+rule321 = describe "3.2.1: Doe je wat je wilt doen? vermenigvuldig de hele linkerkant met p" $
+   buggyBalanceRecognizer "misc2" t
+ where -- currently, not symmetric
+   t = transMaybe (uncurry p) >>> writeRef_ factorRef
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      d <- diffTimes a2 b2
+      let as = from simpleSumView a1
+      guard (d `notElem` [1, -1] && length as > 1)
+      guard $ flip any (take (length as) [0..]) $ \i ->
+         let (xs,y:ys) = splitAt i as
+             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
+         in viewEquivalent (polyViewWith rationalView) aps b1
+      return d
+
+-- a-b=c  -> -a-b=-c
+rule322 :: Rule (Equation Expr)
+rule322 = describe "3.2.2: Doe je wat je wilt doen? neem het tegengestelde van de hele linkerkant" $
+   buggyBalanceRule "misc3" f
+ where
+   f (expr :==: c) = do
+      (a, b) <- match minusView expr
+      return $ -a-b :==: -c
+
+-- pax+pb=pc  ->  ax+pb=c
+rule323 :: Rule (Equation Expr)
+rule323 = describe "3.2.3: Doe je wat je wilt doen? Deel de hele linkerkant door p" $
+   buggyBalanceRecognizer "misc4" t
+   -- REFACTOR: code copied from rule misc2
+ where -- currently, not symmetric
+   t = transMaybe (uncurry p) >>> writeRef_ factorRef
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      d  <- diffTimes a2 b2
+      dr <- matchM rationalView d
+      let as = from simpleSumView a1
+      guard (dr `notElem` [0, 1, -1] && numerator dr == 1 && length as > 1)
+      guard $ flip any (take (length as) [0..]) $ \i ->
+         let (xs,y:ys) = splitAt i as
+             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
+         in viewEquivalent (polyViewWith rationalView) aps b1
+      return (fromRational (1/dr))
+ src/Domain/Math/Polynomial/BuggyRules.hs view
@@ -0,0 +1,464 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Some buggy rules catching common misconceptions (also on the abc-formula)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.BuggyRules
+   ( buggyRulesExpr, buggyRulesEquation
+   , abcBuggyRules, buggyQuadratic, buggySquareMultiplication
+   ) where
+
+import Control.Monad
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library hiding (makeRule, ruleList, (.*.))
+import Prelude hiding ((^))
+import qualified Ideas.Common.Library as C
+
+makeRule :: IsId n => n -> Transformation a -> Rule a
+makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a
+makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a
+ruleList :: (RuleBuilder f a, IsId n) => n -> [f] -> Rule a
+
+makeRule           = buggyName C.ruleTrans
+makeSimpleRule     = buggyName C.makeRule
+makeSimpleRuleList = buggyName C.makeRule
+ruleList           = buggyName C.rewriteRules
+
+buggyName :: IsId n => (Id -> a) -> n -> a
+buggyName f s = f ("algebra.equations.buggy" # s)
+
+buggyRulesExpr :: [Rule Expr]
+buggyRulesExpr =
+   map (siblingOf distributeTimes)
+   [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign
+   , buggyDistrTimesTooMany, buggyDistrTimesDenom
+   ] ++
+   [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined
+   ]
+
+buggyRulesEquation :: [Rule (Equation Expr)]
+buggyRulesEquation =
+   [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide
+   , buggyNegateAll
+   , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus
+   , buggyMultiplyOneSide, buggyMultiplyForgetOne
+   ]
+
+buggyPlus :: Rule (Equation Expr)
+buggyPlus = describe "Moving a term from the left-hand side to the \
+   \right-hand side (or the other way around), but forgetting to change \
+   \the sign." $
+   buggy $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM plusView lhs
+      [ a :==: rhs + b, b :==: rhs + a ]
+    `mplus` do
+      (a, b) <- matchM plusView rhs
+      [ lhs + a :==: b, lhs + b :==: a ]
+
+buggyNegateOneSide :: Rule (Equation Expr)
+buggyNegateOneSide = describe "Negate terms on one side only." $
+   buggy $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) ->
+      [ -lhs :==: rhs, lhs :==: -rhs  ]
+
+buggyFlipNegateOneSide :: Rule (Equation Expr)
+buggyFlipNegateOneSide = describe "Negate terms on one side only." $
+   buggy $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) ->
+      [ -rhs :==: lhs, rhs :==: -lhs  ]
+
+buggyNegateAll :: Rule (Equation Expr)
+buggyNegateAll = describe "Negating all terms (on both sides of the equation, \
+   \but forgetting one term." $
+   buggy $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do
+      xs <- matchM sumView lhs
+      ys <- matchM sumView rhs
+      let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys)
+          makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys)
+          makeEq as bs = build sumView as :==: build sumView bs
+          f i j = if i==j then id else negate
+          len as = let n = length as in if n < 2 then -1 else n
+      map makeL [0 .. len xs] ++ map makeR [0 .. len ys]
+
+buggyDivNegate :: Rule (Equation Expr)
+buggyDivNegate = describe "Dividing, but wrong sign." $
+   buggy $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM timesView lhs
+      [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ]
+    `mplus` do
+      (a, b) <- matchM timesView rhs
+      [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ]
+
+buggyDivNumDenom :: Rule (Equation Expr)
+buggyDivNumDenom = describe "Dividing both sides, but swapping \
+   \numerator/denominator." $
+   buggy $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM timesView lhs
+      [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ]
+    `mplus` do
+      (a, b) <- matchM timesView rhs
+      [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ]
+
+buggyDistrTimes :: Rule Expr
+buggyDistrTimes = describe "Incorrect distribution of times over plus: one \
+   \term is not multiplied." $
+   buggy $ makeSimpleRuleList "distr-times-plus" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a*b+c, b+a*c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ a*c+b, a+b*c ]
+
+buggyDistrTimesForget :: Rule Expr
+buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \
+   \one term is forgotten." $
+   buggy $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b]
+ where
+   forget :: Expr -> [Expr]
+   forget expr =
+      case match productView expr of
+         Just (b, xs) | n > 1 ->
+            [ build productView (b, make i) | i <- [0..n-1] ]
+          where
+            make i = [ x | (j, x) <- zip [0..] xs, i/=j ]
+            n = length xs
+         _ -> [0]
+
+buggyDistrTimesSign :: Rule Expr
+buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \
+   \changing sign of addition." $
+   buggy $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a.*.b .-. a.*.c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ a.*.c .-. b.*.c ]
+
+buggyDistrTimesTooMany :: Rule Expr
+buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \
+   \a*(b+c)+d, where 'a' is also multiplied to d." $
+   buggy $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do
+      ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr
+      [cleanUpExpr $ a*b+a*c+a*d]
+
+buggyDistrTimesDenom :: Rule Expr
+buggyDistrTimesDenom = describe "Incorrect distribution of times over plus: \
+   \one of the terms is a fraction, and the outer expression is multiplied by \
+   \the fraction's denominator." $
+   buggy $ makeSimpleRuleList "distr-times-denom" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [(1/a)*b + a*c, a*b + (1/a)*c]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [a*(1/c) + b*c, a*c + b*(1/c)]
+
+buggyMinusMinus :: Rule Expr
+buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \
+   \change sign." $
+   buggy $ makeSimpleRule "minus-minus" $ \expr ->
+      case expr of
+         a :-: (b :-: c)  -> Just (a-b-c)
+         Negate (a :-: b) -> Just (a-b)
+         _ -> Nothing
+
+buggyCancelMinus :: Rule (Equation Expr)
+buggyCancelMinus = describe "Cancel terms on both sides, but terms have \
+   \different signs." $
+   buggy $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do
+      xs <- matchM sumView lhs
+      ys <- matchM sumView rhs
+      [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys
+           , cleanUpExpr x == cleanUpExpr (-y)
+           , let f n as = build sumView $ take n as ++ drop (n+1) as
+           , let eq = f i xs :==: f j ys
+           ]
+
+buggyPriorityTimes :: Rule Expr
+buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \
+   \ignoring some parentheses." $
+   buggy $ makeSimpleRuleList "priority-times" $ \expr -> do
+      (a, (b, c)) <- matchM (plusView >>> second timesView) expr
+      [(a+b)*c]
+    `mplus` do
+      ((a, b), c) <- matchM (plusView >>> first timesView) expr
+      [a*(b+c)]
+
+buggyMultiplyOneSide :: Rule (Equation Expr)
+buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $
+   addRecognizerBool recognizeEq $ buggy $ buggyName emptyRule "multiply-one-side"
+ where
+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
+      let p r  = r `notElem` [-1, 0, 1] &&
+                 any (myEq eq2) (multiplyOneSide (fromRational r) eq1)
+      in maybe False p (recognizeMultiplication a1 b1)
+      || maybe False p (recognizeMultiplication a2 b2)
+
+recognizeMultiplication :: Expr -> Expr -> Maybe Rational
+recognizeMultiplication a b = do
+   (_, pa) <- match (polyViewWith rationalView) a
+   (_, pb) <- match (polyViewWith rationalView) b
+   let d = coefficient (degree pa) pa
+   guard (d /= 0)
+   return (coefficient (degree pb) pb / d)
+
+multiplyOneSide :: Expr -> Equation Expr -> [Equation Expr]
+multiplyOneSide r (lhs :==: rhs) = do
+   xs <- matchM sumView lhs
+   ys <- matchM sumView rhs
+   let f = map (*r)
+   [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)]
+
+buggyMultiplyForgetOne :: Rule (Equation Expr)
+buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \
+   \equation, but forget one." $
+   addRecognizerBool recognizeEq $ buggy $ buggyName emptyRule "multiply-forget-one"
+ where
+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
+      let p r  = r `notElem` [-1, 0, 1] &&
+                 any (myEq eq2) (multiplyForgetOne (fromRational r) eq1)
+      in maybe False p (recognizeMultiplication a1 b1)
+      || maybe False p (recognizeMultiplication a2 b2)
+
+multiplyForgetOne :: Expr -> Equation Expr -> [Equation Expr]
+multiplyForgetOne r (lhs :==: rhs) = do
+   xs <- matchM sumView lhs
+   ys <- matchM sumView rhs
+   let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys)
+       makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys)
+       f as bs = build sumView as :==: build sumView bs
+       mul b   = if b then (*r) else id
+   do guard (length xs > 1)
+      map makeL [0 .. length xs-1]
+    `mplus` do
+      guard (length ys > 1)
+      map makeR [0 .. length ys-1]
+
+-- Redundant function; should come from exercise
+myEq :: Equation Expr -> Equation Expr -> Bool
+myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr)
+
+---------------------------------------------------------
+-- Quadratic and Higher-Degree Polynomials
+
+buggyQuadratic :: IsTerm a => [Rule (Context a)]
+buggyQuadratic =
+   map use
+      [ buggyCoverUpTimesMul, buggyCoverUpEvenPower
+      , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth
+      , buggyDivisionByVarZero
+      ] ++
+   map use
+      [ buggyDistributionSquare, buggyDistributionSquareForget
+      , buggySquareMultiplication
+      ] ++
+   map use
+      [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget
+      , buggyCoverUpSquareMinus
+      ]
+
+buggyCoverUpEvenPower :: Rule (Equation Expr)
+buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \
+   \the negative root" $ buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) ->
+      make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab c = do
+      (a, b) <- isBinary powerSymbol ab
+      n <- matchM integerView b
+      guard (n > 0 && even n)
+      return (a `equals` root c (fromInteger n))
+
+buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr))
+buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \
+   \but there is some other operation to be done first. Example: x^2+1=9" $
+   buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power-too-early" $
+      oneDisjunct $ helperBuggyCUPower True
+
+buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr))
+buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \
+   \but there is some other operation to be done first. Example: 9*x^2=81, \
+   \ and rewriting this into x=9 or x=-9." $
+   buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power-forget" $
+      oneDisjunct $ helperBuggyCUPower False
+
+helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)]
+helperBuggyCUPower mode (lhs :==: rhs) =
+   make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab c = do
+      (sym, xs) <- getFunction ab
+      (i, x)    <- zip [0..] xs
+      (a, b)    <- isBinary powerSymbol x
+      n         <- matchM integerView b
+      guard (n > 0 && even n)
+      let opa | mode      = function sym (take i xs ++ [a] ++ drop (i+1) xs)
+              | otherwise = a
+          rb  = root c (fromInteger n)
+      return $ toOrList [opa `equals` rb, opa `equals` (-rb)]
+
+buggyCoverUpTimesMul :: Rule (Equation Expr)
+buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \
+   \dividing the right-hand side, multiplication is used." $
+   buggy $ siblingOf coverUpTimes $
+   makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do
+      guard (rhs /= 0)
+      (a, b) <- isTimes lhs
+      [a :==: rhs*b, b :==: rhs*a]
+    `mplus` do
+      guard (lhs /= 0)
+      (a, b) <- isTimes rhs
+      [lhs*a :==: b, lhs*b :==: a]
+
+buggyDistributionSquare :: Rule Expr
+buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \
+   \addition: forgetting the 2ab term" $
+   buggy $ siblingOf distributionSquare $
+   ruleList "distr-square"
+      [ \a b -> (a+b)^2 :~> a^2+b^2
+      , \a b -> (a-b)^2 :~> a^2-b^2
+      , \a b -> (a-b)^2 :~> a^2+b^2
+      ]
+
+buggyDistributionSquareForget :: Rule Expr
+buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \
+   \addition: squaring only one term" $
+   buggy $ siblingOf distributionSquare $
+   ruleList "distr-square-forget"
+      [ \a b -> (a+b)^2 :~> a^2+b
+      , \a b -> (a+b)^2 :~> a+b^2
+      , \a b -> (a-b)^2 :~> a^2-b
+      , \a b -> (a-b)^2 :~> a-b^2
+      ]
+
+buggySquareMultiplication :: Rule Expr
+buggySquareMultiplication = describe "Incorrect square of a term that involves \
+   \a multiplication." $ buggy $
+   ruleList "square-multiplication"
+      [ \a b -> (a*b)^2 :~> a*b^2
+      , \a b -> (a*b)^2 :~> a^2*b
+      , \a b -> a*b^2   :~> (a*b)^2
+      , \a b -> a^2*b   :~> (a*b)^2
+      ]
+
+buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr))
+buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \
+   \on the right-hand side, resulting in an error in the signs" $
+   buggy $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq ->
+      case eq of
+         Sym s [a, 2] :==: b | isPowerSymbol s ->
+            Just $ toOrList [a :==: sqrt b, a :==: sqrt (-b)]
+         _ -> Nothing
+
+buggyCoverUpTimesWithPlus :: Rule (Equation Expr)
+buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \
+   \addition on the other side. Only one of the terms is divided." $
+   buggy $ makeSimpleRuleList "coverup.times-with-plus" $
+   \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab cd = do
+      (a, b) <- isTimes ab
+      (c, d) <- isPlus cd
+      [ a `equals` (c/b+d), a `equals` (c+d/b),
+        b `equals` (c/a+d), b `equals` (c+d/a) ]
+
+buggyDivisionByVarBoth :: Rule (Equation Expr)
+buggyDivisionByVarBoth = describe "Divide both sides by variable, without \
+   \introducing the x=0 alternative." $
+   buggy $ makeSimpleRule "division-by-var-both" $
+   \(lhs :==: rhs) -> do
+      (s1, p1) <- match polyView lhs
+      (s2, p2) <- match polyView rhs
+      let n = lowestDegree p1 `min` lowestDegree p2
+      guard (n > 0 && s1==s2)
+      let f p = build polyView (s1, raise (-n) p)
+      return (f p1 :==: f p2)
+
+buggyDivisionByVarZero :: Rule (Equation Expr)
+buggyDivisionByVarZero = describe "Divide both sides by variable, without \
+   \introducing the x=0 alternative." $
+   buggy $ makeSimpleRuleList "division-by-var-zero" $
+   \(lhs :==: rhs) -> do
+      guard (rhs == 0)
+      (s, p) <- matchM polyView lhs
+      let n = lowestDegree p
+      guard (n > 0)
+      -- Quick fix to do some trivial steps for a linear equation, so that
+      -- buggy rules are recognized.
+      let eq = build polyView (s, raise (-n) p) :==: 0
+      eq : applyM coverUpPlus eq
+
+---------------------------------------------------------
+-- ABC formula misconceptions
+
+abcBuggyRules :: [Rule (OrList (Equation Expr))]
+abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ]
+
+abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)])
+                 -> Transformation (OrList (Equation Expr))
+abcMisconception f = makeTrans $
+   oneDisjunct $ \(lhs :==: rhs) -> do
+      guard (rhs == 0)
+      (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs
+      f x a b c
+
+minusB :: Rule (OrList (Equation Expr))
+minusB = buggy $ makeRule "abc.minus-b" $
+   abcMisconception $ \x a b c -> do
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op bug =
+             let minus = if bug then id else negate
+             in Var x :==: (minus (fromRational b) `op` discr) / (2 * fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+twoA :: Rule (OrList (Equation Expr))
+twoA = buggy $ makeRule "abc.two-a" $
+   abcMisconception $ \x a b c -> do
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op bug =
+             let twice = if bug then id else (2*)
+             in Var x :==: (-fromRational b `op` discr) / twice (fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+minus4AC :: Rule (OrList (Equation Expr))
+minus4AC = buggy $ makeRule "abc.minus-4ac" $
+   abcMisconception $ \x a b c -> do
+      let discr op = sqrt (fromRational ((b*b) `op` (4 * a * c)))
+          f op bug =
+             let sign = if bug then (+) else (-)
+             in Var x :==: (-fromRational b `op` discr sign) / (2 * fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+oneSolution :: Rule (OrList (Equation Expr))
+oneSolution = buggy $ makeRule "abc.one-solution" $
+   abcMisconception $ \x a b c ->
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op = Var x :==: (-fromRational b `op` discr) / (2 * fromRational a)
+      in [ singleton $ f (+), singleton $ f (-) ]
+ src/Domain/Math/Polynomial/Examples.hs view
@@ -0,0 +1,396 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Example exercises from the Digital Mathematics Environment (DWO)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.Examples
+   ( linearExamples, quadraticExamples, higherDegreeExamples
+   , factorizeExamples, expandExamples
+   , ineqLin1, ineqQuad1, ineqQuad2, extraIneqQuad, ineqHigh
+   ) where
+
+import Data.Monoid
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Exercise
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+x :: Expr
+x = variable "x"
+
+linearExamples :: Examples (Equation Expr)
+linearExamples =
+   examplesFor Easy -- applet level 1
+      [ 5*x + 3   :==: 18
+      , 11*x - 12 :==: 21
+      , 19 - 3*x  :==: -5
+      , -12 + 5*x :==: 33
+      , 15 - 9*x  :==: 6
+      , 4*x + 18  :==: 0
+      , 11*x - 12 :==: -34
+      , -2*x - 3  :==: -4
+      , 6*x - 12  :==: 2
+      , -4*x - 13 :==: -11
+      ] <>
+   examplesFor Easy -- applet level 2
+      [ 6*x-2    :==: 2*x+14
+      , 3+6*x    :==: 3*x+24
+      , 5*x+7    :==: 2*x - 10
+      , 2*x-8    :==: 18 - x
+      , 4*x - 6  :==: 7*x - 14
+      , -1 -5*x  :==: 3*x - 20
+      , 4*x - 7  :==: -5*x - 24
+      , 4*x - 18 :==: 14 + 11*x
+      , 17       :==: 4 - 10*x
+      , -5*x + 6 :==: 2 - 3*x
+      ] <>
+   examplesFor Medium -- applet level 3
+      [ 4*(x-1)          :==: 11*x - 12
+      , 4*(x-4)          :==: 5*(2*x+1)
+      , 2*(5-3*x)        :==: 6-x
+      , 4*x - (x-2)      :==: 12 + 5*(x-1)
+      , -3*(x-2)         :==: 3*(x+4) - 7
+      , 3*(4*x-1) + 3    :==: 7*x - 14
+      , 4*(4*x - 1) - 2  :==: -3*x + 3*(2*x -5)
+      , 2*x - (3*x + 5)  :==: 10 + 5*(x-1)
+      , -5*(x+1)         :==: 9*(x+4)-5
+      , 18 - 2*(4*x + 2) :==: 7*x - 4*(4*x -2)
+      ] <>
+   examplesFor Medium -- applet level 4
+      [ (1/2)*x - 4            :==: 2*x + mixed 2 1 2
+      , (1/4)*x + (1/2)        :==: (5/2)*x + 2
+      , (1/4)*x - (3/4)        :==: 2*x + (1/2)
+      , -(1/2)*x + (3/4)       :==: (5/2)*x + 3
+      , -(1/2)*x + mixed 1 1 2 :==: 2*x - 5
+      , -(1/3)*x + (3/4)       :==: (1/4)*x + (1/6)
+      , (3/4)*x - (1/3)        :==: (2/3)*x - (3/4)
+      , (2/5)*x - (1/4)        :==: (1/2)*x + (3/4)
+      , (2/3)*x - 2            :==: (1/5)*x - (3/5)
+      , (-mixed 1 2 5)*x + mixed 3 1 2 :==: (3/5)*x + (9/10)
+      ] <>
+   examplesFor Medium -- applet level 4
+      [ (1/4)*(x-3)         :==: (1/2)*x - 4
+      , (x+3)/2             :==: 5*((1/2)*x + mixed 1 1 2)
+      , (1/2)*(7-(2/3)*x)   :==: 2 + (1/9)*x
+      , (3/4)*x - (x-1)     :==: 3 + mixed 2 1 2*(x-1)
+      , -(5/4)*(x-7)        :==: (3/4)*(x+2) - mixed 4 1 2
+      , 3*((1/5)*x - 1) + 5 :==: 7*x - 14
+      , ((5*x - 1) / 6) - 2 :==: -4*x + (3*x - 6)/2
+      , 2*x - ((2*x+2)/5)   :==: 12 + (x-1)/6
+      , (-3*(x+2))/6        :==: 9*((2/3)*x + (1/3)) - (5/3)
+      , 1 - ((4*x + 2)/3)   :==: 3*x - ((5*x - 1) / 4)
+      ]
+
+quadraticExamples :: Examples (Equation Expr)
+quadraticExamples =
+   examplesFor Easy -- applet level 1
+      [ x^2            :==: 2
+      , x^2+3          :==: 52
+      , x^2-7          :==: 0
+      , 9*x^2 - 6      :==: 75
+      , 32 - 2*x^2     :==: 14
+      , 2*(x^2 - 3)    :==: 12
+      , (1/4)*x^2 + 12 :==: 16
+      , (x-1)^2        :==: 100
+      , 14 - 2*x^2     :==: 6
+      , (1/4)*(17-x^2) :==: 2
+      ] <>
+   examplesFor Medium -- applet level 2
+      [ (x-7)^2 + 3      :==: 11
+      , (6-2*x)^2        :==: 81
+      , (1/2)*(x+9)^2    :==: 4
+      , (3-x^2)/10       :==: 2
+      , 5*x^2 + 3*x      :==: 3*x + 2
+      , 11 - (2*x + 1)^2 :==: 5
+      , (6*x - 3)^2 + 6  :==: 12
+      , (7+2*x)^2        :==: 7
+      , 4 - (x^2 / 10)   :==: 6
+      , 12 - (2*x + 3)^2 :==: 6
+      ] <>
+   examplesFor Medium -- applet level 3
+      [ x^2           :==: 5*x
+      , x^2 - 6*x     :==: 0
+      , 6*x + x^2     :==: 0
+      , x*(x+4)       :==: 0
+      , x*(2*x-4)     :==: 0
+      , 3*x^2         :==: 6*x
+      , 3*x           :==: 2*x^2
+      , x*(1-6*x)     :==: 0
+      , (x+5)*(x-8)   :==: 0
+      , (3*x-1)*(x+3) :==: 0
+      ] <>
+   examplesFor Medium -- applet level 4
+      [ x^2-2*x     :==: 3
+      , x^2+12*x+20 :==: 0
+      , x^2-x       :==: 30
+      , x*(x+2)     :==: 8
+      , x*(x-3)     :==: 4
+      , 2*x+15      :==: x^2
+      , 4*x         :==: 12 - x^2
+      , x^2         :==: 15 - 8*x
+      , x^2-9*x+18  :==: 0
+      , x^2+14*x+24 :==: 0
+      ] <>
+   examplesFor Difficult -- applet level 5
+      [ (3*x+5)^2+(x-5)^2 :==: 40
+      , 4*(10-x^2)        :==: -2*x*(2*x + 10)
+      , x*(x+12)          :==: 2*x^2
+      , 3*(x-2)*(x+6)     :==: 12*x
+      , 8*x^2+4*x-24      :==: (x+3)*(x-8)
+      , 3*x^2 - 11        :==: (3+2*x)^2
+      , 2*x*(x-3)-3       :==: (x+2)*(x+6)
+      , 12*(x^2-3*x)+8    :==: 56
+      , 4*x^2-6*x         :==: x^2+9
+      , (x+1)*(x-5)       :==: (x-2)*(x-3)
+      ] <>
+   examplesFor Difficult -- applet level 6
+      [ x^2+4*x-4   :==: 0
+      , x^2-6*x     :==: 4
+      , x^2-12*x+34 :==: 0
+      , 2*x^2+4*x-8 :==: 0
+      , (x-4)*(x-1) :==: 11
+      , (x-(7/2))^2 :==: 2*(x+4)
+      , x^2-3*x     :==: 3*(x-2)
+      , (4-x)*(1-x) :==: 3*x
+      , 2*x^2       :==: x*(x+2)+7
+      , (1-x)^2     :==: x+2
+      ]
+
+factorizeExamples :: Examples Expr
+factorizeExamples =
+   examplesFor Easy
+      [ -- (buiten haakjes brengen)
+       4*x^2 -4*x
+      , 36*x^2+30*x
+      , -6*x^2-18*x
+      , 14*x^2-10*x
+        --(product-som methode)
+      , x^2+11*x+24
+      , x^2-8*x+15
+      , x^2-x-2
+      , x^2-11*x+28
+      ]
+
+expandExamples :: Examples Expr
+expandExamples = examplesFor Easy
+   [ 5*(x+1), -3*(x-3), (x-1)*7
+   , 4*(3-2*x), (x+1)*(x-3), (x+1)*(1-x)
+   , x*(x-1), 3*(x-2)*2*x
+   , (x-1)^2, (x+1)^2, (x-1)^2*(x+1)
+   , (x+1)^3, (x-1)^3*x, (x-1)*(x+3)*(x-5)
+   , x/2, (x+1)/2, (x+1)/2 + (x+2)/3, ((x+1)/2) * ((x+2)/3)
+   ]
+
+--------------------------------------------------------------------
+-- Algemene applet
+
+higherDegreeExamples :: Examples (Equation Expr)
+higherDegreeExamples =
+   -- Havo B hoofdstuk 3, Hogeregraadsvgl.
+   examplesFor Easy
+      [ -- level 1
+        (1/3)*x^3 :==: 9
+      , x^5 - 12 :==: 20
+      , 1 - 8*x^3 :==: -124
+      , 16 - 32*x^5 :==: - 227
+        -- level 2
+      , 3*x^4 :==: 48
+      , (1/9)*x^6 + 12 :==: 93
+      , 39 - 8*x^2 :==: 21
+      , (1/2)*x^4 - 13 :==: 27.5
+        -- level 3
+      , 3*(2*x-1)^3 + 11 :==: 659
+      , 0.5*(3*x-4)^5 + 7 :==: 23
+      , 2*(0.5*x+3)^7 - 11 :==: -9
+      , 5*(1-4*x)^3 + 4 :==: -621
+        -- level 4
+      , 3*(2*x + 5)^2 + 9 :==: 21
+      , 2*(3*x-6)^6 - 24 :==: -22
+      , -2*(4*x-5)^4 + 192 :==: -8000
+      , (3-2*x)^4 + 23 :==: 279
+      ] <>
+   examplesFor Easy
+      [ -- level 1
+        2*x^3 + 9 :==: 19
+      , 4*x^5 - 17 :==: 27
+      , 3*x^7 + 9 :==: 62
+      , 5*x^3 - 1 :==: 9
+      , 6 - 5*x^3 :==: 76
+      , 11 - 7*x^5 :==: 53
+      , 4 - 0.2*x^7 :==: 9
+      , 18 - 11*x^7 :==: 62
+        -- level 2
+      , 0.5*x^4 + 5 :==: 12
+      , 5*x^6 - 37 :==: 68
+      , 4*x^8 - 19 :==: 9
+      , 5*x^6 + 7 :==: 97
+      , 18 - 7*x^4 :==: -38
+      , 3 + (1/3)*x^6 :==: 7
+      , 1 - (1/9)*x^8 :==: -4
+      , 47 + 15*x^8 :==: 77
+        -- level 3
+      , 18*x^8 - 11 :==: 7
+      , (1/4)*x^6 + 14 :==: 30
+      , 5*x^4 + 67 :==: 472
+      , 5*x^4 - 1 :==: 4
+      , (1/8)*x^7 + 24 :==: 40
+      , 0.2*x^3 + 27 :==: 52
+      , 32*x^3 + 18 :==: 22
+      , 4*x^3 - 8 :==: 100
+        -- level 4
+      , 14 -2*x^3 :==: 700
+      , 4-3*x^5 :==: 100
+      , 14 - 11*x^7 :==: 25
+      , 1 - 3*x^5 :==: 97
+      , 3*(x-2)^4 + 7 :==: 37
+      , 6 - (2*x-1)^3 :==: 1
+      , (1/3)*(x+5)^6 - 4 :==: 3
+      , 6 - 0.5*(x-1)^5 :==: 10
+        -- level 5
+      , (1/2)*(3*x-1)^4 :==: 8
+      , 100-(1/3)*(4*x-3)^5 :==: 19
+      , 4*(0.5*x+2)^6 + 5 :==: 9
+      , 3*(2*x + 7)^3 + 11 :==: 35
+      ] <>
+   examplesFor Medium
+      -- (Ontbinden applet)
+      [ -- level 1
+        x^3 - 5*x^2 + 4*x :==: 0
+      , x^3 :==: 3*x^2 + 10*x
+      , 14*x :==: x^3 + 5*x^2
+      , (1/2)*x^3 + 3*x^2 + 4*x :==: 0
+      , x^3 + 6*x^2 + 9*x :==: 0
+      , 5*x^2 :==: x^3 + 6*x
+      , x^3 - 5*x^2 :==: 6*x
+      , x^3 :==: 4*x^2 + 12*x
+        -- level 2
+      , x^4 + 36 :==: 13*x^2
+      , x^4 - 9*x^2 + 20 :==: 0
+      , x^4 :==: 2*x^2 + 3
+      , x^4 + 2*x^2 :==: 24
+      , 7*x^2 + 18 :==: x^4
+      , x^4 :==: x^2 + 12
+      , 29*x^2 :==: x^4 + 100
+      , 2*x^4 + 2*x^2 :==: 12
+        -- (abc-form applet)
+        -- level 1
+      , 4*x^4 + 4 :==: 17*x^2
+      , 16*x^4 + 225 :==: 136*x^2
+      , 2*x^4 - 15*x^2 + 25 :==: 0
+      , 9*x^4 - 28*x^2 + 3 :==: 0
+      , 3*x^4 - 14*x^2 - 5 :==: 0
+      , 2*x^4 :==: x^2 + 3
+      , 9*x^4 + 14*x^2 :==: 8
+      , 4*x^4 - 29*x^2 - 24 :==: 0
+        -- level 2
+      , 8*x^6 - 9*x^3 + 1 :==: 0
+      , 27*x^6 + 8 :==: 217*x^3
+      , 2*x^6 + x^3 - 1 :==: 0
+      , 8*x^6 + 31*x^3 :==: 4
+      , 3*x^6 - 80*x^3 - 27 :==: 0
+      , 5*x^6 :==: 39*x^3 + 8
+      , 7*x^6 + 8*x^3 + 1 :==: 0
+      , 4*x^6 + 2 :==: -9*x^3
+      ] <>
+   examplesFor Difficult
+      [ x^3 + x^2 :==: 0
+      , x^3 - 5*x :==: 0
+      , x^3 - 11*x^2 + 18*x :==: 0
+      , x^3 + 36*x :==: 13*x^2
+      , x^3 + 2*x^2 :==: 24*x
+      , 7*x^3 :==: 8*x^2
+      , x^4 :==: 9*x^2
+      , 64*x^7 :==: x^5
+      , x^3 - 4*x^2 - 9*x :==: 0
+      , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2
+      ]
+
+--------------------------------------------------------------------
+-- Havo applets
+
+-- Havo B Voorkennis: lineaire ongelijkheden
+ineqLin1 :: [[Inequality Expr]]
+ineqLin1 =
+   let a = Var "a" in
+   [ [ 7*x - 12 :<: 5*x + 3
+     , 4*(x-3) :>: 3*(x-4)
+     , 6*(a+1) :<: 3*(a-2)+4
+     , 5 - 2*(a-3) :>: 5*(3-a)
+     ]
+   , [ 4*x+5 :<: 5*x - 3
+     , (1/3)*x+10 :>: (1/2)*x
+     , 3*x+1 :<: 7*x + 5
+     , x+6 :>: 2 - (3/4)*x
+     ]
+   , [ 5*(x-1) :<: 7*x - 1
+     , -3*(4*x-1) :>: 2-(x-1)
+     , 2*(3*x-1) :<: 5-(2-9*x)
+     , 2*(x-1)-3*(x-2) :>: 6
+     ]
+   ]
+
+-- Havo B Voorkennis: kwadratische ongelijkheden
+-- (door eerst gelijkheid op te lossen)
+-- (level 2 uit Hoofdstuk 3)
+ineqQuad1 :: [[Inequality Expr]]
+ineqQuad1 =
+   [ [ x^2 +3*x-4 :<: 0
+     , x^2-4*x-12 :>: 0
+     , -x^2 - 4*x + 5 :<: 0
+     , -x^2 + 3*x + 18 :>: 0
+     , (1/2)*x^2 - 3*x - 8 :<: 0
+     , -2*x^2 + 10*x :>: 0
+     ]
+   , [ x^2 + 9*x :<: 3*x - 5
+     , x^2 - x :>: 12
+     , x^2 - 4.5*x :<: 7-3*x
+     , 2*x^2 - 10*x :>: x^2 - 3*x
+     , 4*x^2 + 6*x :<: x^2 + 3*x + 18
+     , 2*x^2 + 6*x - 10 :>: x^2 + 2*x - 5
+     ]
+   ]
+
+-- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact
+-- (door eerst gelijkheid op te lossen)
+ineqHigh :: [Inequality Expr]
+ineqHigh =
+   [ 2*x^3 :>: 54
+   , -0.5*x^4 :<: -40.5
+   , 1 - 2*x^5 :<: -485
+   , (2*x-3)^4 :>: 1
+   , -(0.5*x+2)^3 :<: -1
+   , 0.25*(0.5*x-2)^4 :<: 4
+   ]
+
+--------------------------------------------------------------------
+-- VWO A/C applets
+
+-- hoofdstuk 2
+ineqQuad2 :: [Inequality Expr]
+ineqQuad2 =
+   [ x^2 + 9*x :<: 3*x - 5
+   , x^2 - x :>: 12
+   , x^2 - 4.5*x :<: 7 - 3*x
+   , 2*x^2 - 10*x :>: x^2 - 3*x
+   , 4*x^2 + 6*x :<: x^2 + 3*x + 18
+   , 2*x^2 + 6*x - 10 :>: x^2 +2*x - 5
+   ]
+
+--------------------------------------------------------------------
+-- Extra test cases
+
+extraIneqQuad :: [Inequality Expr]
+extraIneqQuad =
+   [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x
+   , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0
+   ]
+ src/Domain/Math/Polynomial/Generators.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.Generators
+   ( polynomialGen, polynomialDegreeGen
+   , cubicGen, quadraticGen, linearGen
+   ) where
+
+import Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Numeric.Generators
+import Prelude hiding ((^))
+import Test.QuickCheck
+
+polynomialGen :: Int -> Gen Expr
+polynomialGen n = do
+   d <- choose (0, n `div` 5)
+   polynomialDegreeGen d n
+
+-- Random polynomial generator for (exactly) degree d
+-- No division by zero
+polynomialDegreeGen :: Int -> Int -> Gen Expr
+polynomialDegreeGen d n
+   | d==0         = ratGen
+   | n==0 && d==1 = return (Var "x")
+   | n==0         = return (Var "x" ^ fromIntegral d)
+   | otherwise    = oneof $
+        [ timesGen, plusGen
+        , liftM2 (:/:) (rec d) ratGenNZ
+        ] ++ [ powerGen | d > 1 ]
+ where
+   rec i = polynomialDegreeGen i (n `div` 2)
+   plusGen = do
+      d1 <- choose (0, d)
+      a <- rec d1
+      b <- rec d
+      elements [a :+: b, b :+: a, a :-: b, b :-: a, Negate b]
+   timesGen = do
+      d1 <- choose (0, d)
+      a  <- rec d1
+      b  <- rec (d-d1)
+      return (a :*: b)
+   powerGen = do
+      i <- elements [ i | i <- [2..d], d `mod` i == 0 ]
+      a <- rec (d `div` i)
+      return (a ^ fromIntegral i)
+
+cubicGen, quadraticGen, linearGen :: Int -> Gen Expr
+cubicGen     = polynomialDegreeGen 3
+quadraticGen = polynomialDegreeGen 2
+linearGen    = polynomialDegreeGen 1
+
+ratGen, ratGenNZ :: Gen Expr
+ratGen   = sized ratioExprGen
+ratGenNZ = sized ratioExprGenNonZero
+ src/Domain/Math/Polynomial/LeastCommonMultiple.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.LeastCommonMultiple
+   ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM
+   , powerProductView
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ratio
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Views
+import Ideas.Utils.TestSuite
+import Ideas.Common.View
+import Prelude hiding ((^))
+import Test.QuickCheck
+
+-- | Returns the least common multiple of two expressions.
+lcmExpr :: Expr -> Expr -> Expr
+lcmExpr a b = fromMaybe (a*b) $ do
+   (ar, as) <- match powerProductView a
+   (br, bs) <- match powerProductView b
+   return $ build powerProductView (lcmR ar br, merge as bs)
+ where
+   lcmR :: Rational -> Rational -> Rational
+   lcmR r1 r2 =
+      let f r = numerator r * denominator r
+      in fromIntegral (lcm (f r1) (f r2))
+
+   merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)]
+   merge = foldr op id
+    where
+      op (e, n1) f ys =
+         let n2   = fromMaybe 0 (lookup e ys)
+             rest = filter ((/=e) . fst) ys
+         in (e, n1 `max` n2) : f rest
+
+-- | Only succeeds if there is no remainder
+divisionExpr :: Expr -> Expr -> Maybe Expr
+divisionExpr a b = do
+   (ar, as) <- match powerProductView a
+   (br, bs) <- match powerProductView b
+   xs       <- as `without` bs
+   return $ build powerProductView (ar/br, xs)
+ where
+   without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)]
+   without [] ys =
+      guard (null ys) >> return []
+   without ((e,n1):xs) ys =
+      let n2   = fromMaybe 0 (lookup e ys)
+          rest = filter ((/=e) . fst) ys
+      in liftM ((e,n1-n2):) (without xs rest)
+
+powerProductView :: View Expr (Rational, [(Expr, Integer)])
+powerProductView = makeView f g
+ where
+   f expr = do
+      (b, xs) <- match productView expr
+      let (r, ys) = collectPairs xs
+      return (if b then -r else r, merge ys)
+
+   g (r, xs) =
+      build productView (False, fromRational r : map (build pvn) xs)
+
+   pvn :: View Expr (Expr, Integer)
+   pvn = powerView >>> second integerView
+
+   collectPairs :: [Expr] -> (Rational, [(Expr, Integer)])
+   collectPairs = foldr op (1, [])
+    where
+      op e (r, xs) =
+         let mr   = match rationalView e
+             h r2 = (r*r2, xs)
+             pair = fromMaybe (e,1) (match pvn e)
+         in maybe (r, pair:xs) h mr
+
+   merge :: [(Expr, Integer)] -> [(Expr, Integer)]
+   merge [] = []
+   merge xs@((e, _) : _) =
+      let (xs1, xs2) = partition ((==e) . fst) xs
+          n = sum (map snd xs1)
+      in (e, n) : merge xs2
+
+testLCM :: TestSuite
+testLCM = suite "lcmExpr"
+   [ useProperty "transitivity" $ f3 $ \a b c ->
+        lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c
+   , useProperty "commutativity" $ f2 $ \a b ->
+        lcmExpr a b ~= lcmExpr b a
+   , useProperty "idempotency" $ f1 $ \a ->
+        lcmExpr a a ~= absExpr a
+   , useProperty "zero" $ f1 $ \a ->
+        lcmExpr a 0 ~= 0
+   , useProperty "one" $ f1 $ \a ->
+        lcmExpr a 1 ~= absExpr a
+   , useProperty "sign" $ f2 $ \a b ->
+        lcmExpr a b ~= lcmExpr (-a) b
+   ]
+ where
+   f1 g = liftM  g genExpr
+   f2 g = liftM2 g genExpr genExpr
+   f3 g = liftM3 g genExpr genExpr genExpr
+
+   genExpr, genTerm, genAtom :: Gen Expr
+   genExpr = do
+      n  <- choose (0, 10)
+      b  <- arbitrary
+      xs <- replicateM n genTerm
+      return $ build productView (b, xs)
+
+   genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)]
+
+   genAtom = do
+      v <- elements $ map Var ["a", "b", "c"]
+      i <- choose (-10, 10)
+      n <- choose (0, 10)
+      p <- frequency [(3, return v), (1, return (v .+. fromInteger i))]
+      frequency [(3, return p), (1, return (p^fromInteger n))]
+
+   (~=)    = equalFactors
+   absExpr = simplifyWith (first (const False)) productView
+
+noCommonFactor :: Expr -> Expr -> Bool
+noCommonFactor x y = lcmExpr x y `equalFactors` (x*y)
+
+equalFactors :: Expr -> Expr -> Bool
+equalFactors x y = f x == f y
+ where f = simplifyWith (second sort) powerProductView
+ src/Domain/Math/Polynomial/RationalRules.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.RationalRules
+   ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend
+   , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv
+   , fractionScale, turnIntoFraction, checkSolution
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import Domain.Logic.Formula hiding (Var)
+import Domain.Logic.Views
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.LeastCommonMultiple
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.Views
+import Ideas.Common.Library hiding ((<>))
+import qualified Domain.Logic.Formula as Logic
+
+ratId :: Id
+ratId = newId "algebra.equations.rational"
+
+---------------------------------------------------------------
+-- Rules for rational expressions and rational equations
+
+-- a/b = 0  iff  a=0 (and b/=0)
+divisionIsZero :: Rule (Context (Equation Expr))
+divisionIsZero = makeRule (ratId, "division-zero") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   guard (rhs == 0)
+   (a, b) <- match divView lhs
+   return $ conditionNotZero b
+          $ replaceInContext (a :==: 0) ceq
+
+-- a/b = 1  iff  a=b (and b/=0)
+divisionIsOne :: Rule (Context (Equation Expr))
+divisionIsOne = makeRule (ratId, "division-one") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   guard (rhs == 1)
+   (a, b) <- match divView lhs
+   return $ conditionNotZero b
+          $ replaceInContext (a :==: b) ceq
+
+-- a/c = b/c  iff  a=b (and c/=0)
+sameDivisor :: Rule (Context (Equation Expr))
+sameDivisor = makeRule (ratId, "same-divisor") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   (a, c1) <- match divView lhs
+   (b, c2) <- match divView rhs
+   guard (c1==c2)
+   return $ conditionNotZero c1
+          $ replaceInContext (a :==: b) ceq
+
+-- a/b = a/c  iff  a=0 or b=c (and b/=0 and c/=0)
+sameDividend :: Rule (Context (OrList (Equation Expr)))
+sameDividend = makeRule (ratId, "same-dividend") $ \cor -> do
+   oreq <- currentInContext cor
+   lhs :==: rhs <- getSingleton oreq
+   (a1, b) <- matchM divView lhs
+   (a2, c) <- matchM divView rhs
+   guard (a1==a2)
+   let new = singleton (a1 :==: 0) <> singleton (b :==: c)
+   return $ conditionNotZero c
+          $ conditionNotZero b
+          $ replaceInContext new cor
+
+-- a/b = c/d  iff  a*d = b*c   (and b/=0 and d/=0)
+crossMultiply :: Rule (Context (Equation Expr))
+crossMultiply = makeRule (ratId, "cross-multiply") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   (a, b) <- match divView lhs
+   (c, d) <- match divView rhs
+   return $ conditionNotZero d
+          $ conditionNotZero b
+          $ replaceInContext (a*d :==: b*c) ceq
+
+-- a/b = c  iff  a = b*c  (and b/=0)
+multiplyOneDiv :: Rule (Context (Equation Expr))
+multiplyOneDiv = ruleList (ratId, "multiply-one-div") $ \ceq -> do
+   lhs :==: rhs <- maybeToList (currentInContext ceq)
+   f (:==:) lhs rhs ceq <|> f (flip (:==:)) rhs lhs ceq
+ where
+   f eq ab c ceq = do
+      guard (not (c `belongsTo` divView))
+      (a, b) <- matchM divView ab
+      return $ conditionNotZero b
+             $ replaceInContext (a `eq` (b*c)) ceq
+
+-- a/c + b/c = a+b/c   (also see Numeric.Rules)
+fractionPlus :: Rule Expr -- also minus
+fractionPlus = makeRule (ratId, "rational-plus") $ \expr -> do
+   ((a, b), (c, d)) <- match myView expr
+   guard (b == d)
+   return (build divView (a+c, b))
+ where
+   myView = plusView >>> (divView *** divView)
+
+-- ab/ac  =>  b/c  (if a/=0)
+-- Note that the common term can be squared (in one of the parts)
+cancelTermsDiv :: Rule (Context Expr)
+cancelTermsDiv = makeRule (ratId, "cancel-div") $ \ce -> do
+   expr <- currentInContext ce
+   ((b, xs), (c, ys)) <- match myView expr
+   let (ps, qs, rs) = rec (map f xs) (map f ys)
+       new = build myView ((b, map g ps), (c, map g qs))
+   guard (not (null rs))
+   return $ conditionNotZero (build productView (False, map g rs))
+          $ replaceInContext new ce
+ where
+   myView = divView >>> toView (productView *** productView)
+   powInt = powerView >>> second integerView
+   f a = fromMaybe (a, 1) (match powInt a)
+   g   = build powInt
+   rec ((_, 0):xs) ys = rec xs ys
+   rec (pair@(a, n):xs) ys =
+      case break ((==a) . fst) ys of
+         (ys1, (b, m):ys2)
+            | m == 0 ->
+                 rec (pair:xs) (ys1++ys2)
+            | otherwise ->
+                 let i = n `min` m
+                     (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2)
+                 in (ps, qs, (a,i):rs)
+         _ ->
+            let (ps,qs,rs) = rec xs ys
+            in (pair:ps, qs,rs)
+   rec xs ys = (xs, ys, [])
+
+fractionScale :: Rule Expr
+fractionScale = liftView myView $
+   makeRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do
+      guard (e1 /= e2)
+      let e3 = lcmExpr e1 e2
+      ma <- divisionExpr e3 e1
+      mb <- divisionExpr e3 e2
+      guard (ma /= 1 || mb /= 1)
+      return ((ma*a, e3), (mb*b, e3))
+ where
+   myView = plusView >>> (divView *** divView)
+
+turnIntoFraction :: Rule Expr
+turnIntoFraction = liftView plusView $
+   makeRule (ratId, "to-rational") $ \(a, b) ->
+      fmap (\c -> (c, b)) (f a b) <|>
+      fmap (\c -> (a, c)) (f b a)
+ where
+   f a b = do
+      guard (not (a `belongsTo` divView))
+      (_, e) <- match divView b
+      return $ build divView (a*e, e)
+
+-- A simple implementation that considers the condition stored in the context
+checkSolution :: Rule (Context (OrList (Equation Expr)))
+checkSolution = makeRule (ratId, "check-solution") $ \cor -> do
+   oreq <- currentInContext cor
+   x :==: a <- getSingleton oreq
+   c  <- lookupClipboardG "condition" cor
+   xs <- match andView c
+   guard ((x ./=. a) `elem` xs)
+   return $ replaceInContext false cor
+
+---------------------------------------------------------------
+-- Helper-code
+
+condition :: Logic (Relation Expr) -> Context a -> Context a
+condition p c
+   | new == T  = {- removeClipboardC "condition" -} c
+   | otherwise = addToClipboardG "condition" new c
+ where
+   mp  = lookupClipboardG "condition" c
+   new = maybe id (.&&.) mp p
+
+conditionNotZero :: Expr -> Context a -> Context a
+conditionNotZero expr = condition (f xs)
+ where
+   f  = pushNotWith (Logic.Var . notRelation) . Not
+   eq = expr :==: 0
+   xs = fmap (build equationView . fmap cleanUpExpr) $
+        case match higherDegreeEquationsView (singleton eq) of
+           Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys))
+           Nothing -> Logic.Var (coverUp eq)
+ src/Domain/Math/Polynomial/Rules.hs view
@@ -0,0 +1,614 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.Rules
+   ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms
+   , commonFactorVar, commonFactorVarNew, defPowerNat
+   , distributeDivisionT, distributeDivisionMulti
+   , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare
+   , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero
+   , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar
+   , prepareSplitSquare, quadraticRuleOrder, removeDivision
+   , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational
+   , ruleNormalizePolynomial
+   , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRootMulti
+   , squareBothSides, substBackVar, varToLeft, conditionVarsRHS, fractionProduct
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Data.Ratio
+import Domain.Math.Approximation (precision)
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.BalanceRules
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.OldViews (powerFactorView)
+import Domain.Math.Safe
+import Domain.Math.Simplification hiding (simplifyWith, distribution)
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library hiding (terms, simplify, merge, (.*.), (./.))
+import Ideas.Utils.Prelude (thd3)
+import Ideas.Utils.Uniplate (universe, descend)
+import Prelude hiding ( (^) )
+import qualified Prelude
+
+quadraticRuleOrder :: [Id]
+quadraticRuleOrder =
+   [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar)
+   , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar)
+   , getId coverUpPower
+   , getId commonFactorVar, getId simplerPolynomial
+   , getId niceFactors, getId noLinFormula
+   , getId cancelTerms, getId sameConFactor, getId distributionSquare
+   , getId allPowerFactors
+   ]
+
+lineq, quadreq, polyeq :: String
+lineq   = "algebra.equations.linear"
+quadreq = "algebra.equations.quadratic"
+polyeq  = "algebra.equations.polynomial"
+
+------------------------------------------------------------
+-- General form rules: ax^2 + bx + c = 0
+
+quadraticNF :: View Expr (String, (Rational, Rational, Rational))
+quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView
+
+-- ax^2 + bx = 0
+commonFactorVar :: Rule (Equation Expr)
+commonFactorVar = rhsIsZero commonFactorVarNew
+
+-- Maybe to be replaced by more general factorVariablePower??
+commonFactorVarNew :: Rule Expr
+commonFactorVarNew = describe "Common factor variable" $
+   makeRule (quadreq, "common-factor") $ \expr -> do
+      (x, (a, b, c)) <- match quadraticNF expr
+      guard (a /= 0 && b /= 0 && c == 0)
+      -- also search for constant factor
+      let d = signum a * gcdFrac a b
+      return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)))
+
+gcdFrac :: Rational -> Rational -> Rational
+gcdFrac r1 r2 =
+   if denominator r1 == 1 && denominator r2 == 1
+   then fromInteger (numerator r1 `gcd` numerator r2)
+   else 1
+
+-- ax^2 + c = 0
+noLinFormula :: Rule (Equation Expr)
+noLinFormula = describe "No linear term ('b=0')" $ liftView myView $
+   ruleMaybe (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do
+      guard (rhs == 0 && b == 0 && c /= 0)
+      return $ if a>0 then ((x, (a, 0, 0)), -c)
+                      else ((x, (-a, 0, 0)), c)
+ where
+   myView = constantRight quadraticNF
+
+-- search for (X+A)*(X+B) decomposition
+niceFactors :: Rule (Equation Expr)
+niceFactors = rhsIsZero niceFactorsNew
+
+-- search for (X+A)*(X+B) decomposition
+niceFactorsNew :: Rule Expr
+niceFactorsNew = describe "Find a nice decomposition" $
+   makeRule (quadreq, "nice-factors") $ \expr -> do
+   let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t
+   (x, (a, b, c)) <- sign <$> matchM (polyNormalForm integerView >>> second quadraticPolyView) expr
+   guard (a==1)
+   let ok (i, j) = i+j == b
+       f  (i, j)
+          | i == j = -- special case
+              (Var x + fromInteger i) ^ 2
+          | otherwise =
+              (Var x + fromInteger i) * (Var x + fromInteger j)
+   map f (filter ok (factors c))
+ where
+   factors :: Integer -> [(Integer, Integer)]
+   factors n = [ pair
+               | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n)))
+               , a <- [1..h], let b = n `div` a, a*b == n
+               , pair <- [(a, b), (negate a, negate b)]
+               ]
+
+-- Simplify polynomial by multiplying (or dividing) the terms:
+-- 1) If a,b,c are ints, then find gcd
+-- 2) If any of a,b,c is a fraction, find lcm of denominators
+-- 3) If a<0, then also suggest to change sign (return two solutions)
+simplerPolynomial :: Rule (Equation Expr)
+simplerPolynomial = describe "simpler polynomial" $
+   rhsIsZero $ liftViewIn (quadraticNF >>> toView swapView) $
+   makeRule (quadreq, "simpler-poly") $ \(a, b, c) -> do
+      r <- findFactor (filter (/=0) [a, b, c])
+      d <- if a >= 0 then [r] else [-r, r]
+      guard (d `notElem` [0, 1])
+      return (a*d, b*d, c*d)
+
+-- Simplified variant of simplerPoly: just bring a to 1.
+-- Needed for quadratic strategy without square formula
+bringAToOne :: Rule (Equation Expr)
+bringAToOne = rhsIsZero $ liftViewIn (quadraticNF >>> toView swapView) $
+   describe "Bring 'a' to one" $
+   ruleMaybe (quadreq, "scale") $ \(a, b, c) -> do
+      guard (a `notElem` [0, 1])
+      return (1, b/a, c/a)
+
+------------------------------------------------------------
+-- General form rules: expr = 0
+
+-- Rule must be symmetric in side of equation
+mulZero :: Rule (OrList (Equation Expr))
+mulZero = describe "multiplication is zero" $
+   makeRule (quadreq, "product-zero") $ oneDisjunct bothSides
+ where
+   bothSides eq = oneSide eq ++ oneSide (flipSides eq)
+   oneSide (lhs :==: rhs) = do
+      guard (rhs == 0)
+      (_, xs) <- matchM productView lhs
+      guard (length xs > 1)
+      return $ toOrList $ flip map xs $ \e ->
+         case match (polyNormalForm rationalView >>> second linearPolyView) e of
+            -- special cases (simplify immediately, as in G&R)
+            Just (x, (a, b))
+               | a == 1 ->
+                    Var x :==: fromRational (-b)
+               | a == -1 ->
+                    Var x :==: fromRational b
+            _ -> e :==: 0
+
+------------------------------------------------------------
+-- Constant form rules: expr = constant
+
+-- Use this configuration for covering-up plus and minus symbols!
+-- Prevent    (x^2+3x)+5 = 0   to be covered up
+oneVar :: ConfigCoverUp
+oneVar = configCoverUp
+   { configName        = "onevar"
+   , predicateCovered  = \a -> p1 a || p2 a
+   , predicateCombined = const True --hasNoVar
+   , coverLHS          = True
+   , coverRHS          = True
+   }
+ where
+   p1 = (\x -> x == 1) . length . vars
+   -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56
+   p2 a = fromMaybe False $ do
+      (x, y) <- match timesView a
+      return (hasSomeVar x /= hasSomeVar y)
+
+------------------------------------------------------------
+-- Top form rules: expr1 = expr2
+
+simplerSquareRootMulti :: IsTerm a => Rule (Context a)
+simplerSquareRootMulti = describe "simpler square root" $
+   makeRule (quadreq, "simpler-sqrt") $ applyAll $
+   repeat1 (somewhere (use (makeRule () simplerSqrt)))
+ where
+   -- Do not simplify (5+sqrt 53)/2
+   simplerSqrt :: Expr -> Maybe Expr
+   simplerSqrt e = do
+      xs <- f e
+      guard (not (null xs))
+      new <- canonical (squareRootViewWith rationalView) e
+      ys <- f new
+      guard (xs /= ys)
+      return new
+
+   -- return numbers under sqrt symbol
+   f :: Expr -> Maybe [Rational]
+   f e = sort <$> sequence [ match rationalView a | Sqrt a <- universe e ]
+
+cancelTerms :: Rule (Equation Expr)
+cancelTerms = describe "Cancel terms" $
+   makeRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do
+   xs <- match sumView lhs
+   ys <- match sumView rhs
+   let zs = filter (`elem` ys) (nub xs)
+   guard (not (null zs))
+   let without as = build sumView (as \\ zs)
+   return (without xs :==: without ys)
+
+-- "merkwaardige producten"
+distributionSquare :: Rule Expr
+distributionSquare = describe "distribution for special products" $
+   rewriteRules (quadreq, "distr-square")
+      [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2
+      , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2
+      , \a b -> (a+b)*(a-b) :~> a^2 - b^2
+      , \a b -> (a-b)*(a+b) :~> a^2 - b^2
+      ]
+
+-- a^2 == b^2
+squareBothSides :: Rule (OrList (Equation Expr))
+squareBothSides = describe "square both sides" $
+   rewriteRule (quadreq, "square-both") $ \a b ->
+   singleton (a^2 :==: b^2) :~> toOrList [a :==: b, a :==: -b]
+
+-- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c
+prepareSplitSquare :: Rule (Equation Expr)
+prepareSplitSquare = describe "prepare split square" $
+   liftView myView $
+   ruleMaybe (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do
+      let newC   = (b/2)*(b/2)
+          newRHS = r + newC - c
+      guard (a==1 && b/=0 && c /= newC)
+      return ((x, (a, b, newC)), newRHS)
+ where
+   myView = constantRight quadraticNF
+
+-- factor left-hand side into (ax + c)^2
+factorLeftAsSquare :: Rule (Equation Expr)
+factorLeftAsSquare = describe "factor left as square" $
+   makeRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do
+      guard (hasNoVar rhs)
+      (x, (a, b, c)) <- match quadraticNF lhs
+      let h = b/2
+      guard (a==1 && b/=0 && h*h == c)
+      return ((Var x + build rationalView h)^2 :==: rhs)
+
+-- flip the two sides of an equation
+flipEquation :: Rule (Equation Expr)
+flipEquation = describe "flip equation" $
+   rewriteRule (lineq, "flip") $ \a b ->
+      (a :==: b) :~> (b :==: a)
+
+conditionVarsRHS :: Equation Expr -> Bool
+conditionVarsRHS (lhs :==: rhs) = hasSomeVar rhs && hasNoVar lhs
+
+-- Afterwards, merge and sort
+moveToLeft :: Rule (Equation Expr)
+moveToLeft = describe "Move to left" $
+   ruleMaybe (quadreq, "move-left") $ \(lhs :==: rhs) -> do
+      guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs))
+      return (collectLikeTerms (sorted (lhs - rhs)) :==: 0)
+ where
+   isComplex = maybe False ((>= 2) . length . filter hasSomeVar)
+             . match sumView . applyD merge
+
+   -- high exponents first, non power-factor terms at the end
+   sorted = simplifyWith (sortBy (comparing toPF)) sumView
+   toPF   = fmap (negate . thd3) . match powerFactorView
+
+ruleApproximate :: Rule (Relation Expr)
+ruleApproximate = describe "Approximate irrational number" $
+   makeRule (quadreq, "approx") $ \relation -> do
+      lhs :==: rhs <- match equationView relation
+      guard (not (simplify rhs `belongsTo` rationalView))
+      x <- getVariable lhs
+      d <- match doubleView rhs
+      let new = fromDouble (precision 4 d)
+      return (Var x .~=. new)
+
+ruleNormalizeRational :: Rule Expr
+ruleNormalizeRational =
+   describe "normalize rational number" $
+   ruleFromView (lineq, "norm-rational") rationalView
+
+ruleNormalizeMixedFraction :: Rule Expr
+ruleNormalizeMixedFraction =
+   describe "normalize mixed fraction" $
+   ruleFromView (lineq, "norm-mixed") mixedFractionView
+
+ruleNormalizePolynomial :: Rule Expr
+ruleNormalizePolynomial =
+   describe "normalize polynomial" $
+   ruleFromView (polyeq, "norm-poly") (polyNormalForm rationalView)
+
+-----------------------------------------------------------
+-------- Rules From HDE
+
+-- X*A + X*B = X*C + X*D
+-- New implementation, but slightly different than original
+-- This one does not factor constants
+
+allPowerFactors :: Rule (OrList (Equation Expr))
+allPowerFactors = describe "all power factors" $
+   makeRule (polyeq, "power-factors") $ oneDisjunct $
+   \(lhs :==: rhs) -> do
+      let myView = polyNormalForm rationalView
+      (s1, p1) <- match myView lhs
+      (s2, p2) <- match myView rhs
+      let n | p1 == 0   = lowestDegree p2
+            | p2 == 0   = lowestDegree p1
+            | otherwise = lowestDegree p1 `min` lowestDegree p2
+          ts  = filter (/= 0) (fromPolynomial p1 ++ fromPolynomial p2)
+          f p = build myView (s1, raise (-n) p)
+      guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1)
+      return $ toOrList [Var s1 :==: 0, f p1 :==: f p2]
+
+factorVariablePower :: Rule Expr
+factorVariablePower = describe "factor variable power" $
+   makeRule (polyeq, "factor-varpower") $ \expr -> do
+   let myView = polyNormalForm rationalView
+   (s, p) <- match (polyNormalForm rationalView) expr
+   let n = lowestDegree p
+   guard (n > 0 && length (filter (/=0) (fromPolynomial p)) > 1)
+   new <- p `safeDiv` (var Prelude.^ n)
+   return $ Var s .^. fromIntegral n * build myView (s, new)
+
+-- A*B = A*C  implies  A=0 or B=C
+sameFactor :: Rule (OrList (Equation Expr))
+sameFactor = describe "same factor" $
+   makeRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do
+      (b1, xs) <- match productView lhs
+      (b2, ys) <- match productView rhs
+      (x, y) <- listToMaybe [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong?
+      return $ toOrList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ]
+
+-- N*(A+B) = N*C + N*D   recognize a constant factor on both sides
+-- Example: 3(x^2+1/2) = 6+6x
+sameConFactor :: Rule (Equation Expr)
+sameConFactor =
+   describe "same constant factor" $
+   liftView myView $
+   makeRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do
+      let (bs, zs) = unzip (ps1 ++ ps2)
+          (rs, es) = unzip (map (f 1 []) zs)
+          f r acc []     = (r, reverse acc)
+          f r acc (x:xs) = case match rationalView x of
+                              Just r2 -> f (r*r2) acc xs
+                              Nothing -> f r (x:acc) xs
+      c <- whichCon rs
+      guard (c /= 1)
+      let make b r e          = (b, fromRational (r/c):e)
+          (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es)
+      return (newLeft :==: newRight)
+ where
+   myView = bothSidesView (toView sumView >>> listView (toView productView))
+
+   whichCon :: [Rational] -> Maybe Rational
+   whichCon xs
+      | all (\x -> denominator x == 1 && x /= 0) xs =
+           Just (fromInteger (foldr1 gcd (map numerator xs)))
+      | otherwise = Nothing
+
+abcFormula :: Rule (Context (OrList (Equation Expr)))
+abcFormula = describe "quadratic formula (abc formule)" $
+   makeRule (quadreq, "abc") $ \cor -> do
+   oreq <- currentInContext cor
+   lhs :==: rhs  <- getSingleton oreq
+   guard (rhs == 0)
+   (x, (a, b, c)) <- matchM quadraticNF lhs
+   let discr = b*b - 4 * a * c
+       sqD   = sqrt (fromRational discr)
+       eqs   = case compare discr 0 of
+                  LT -> false
+                  EQ -> singleton $
+                     Var x :==: (-fromRational b) / (2 * fromRational a)
+                  GT -> toOrList
+                     [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a)
+                     , Var x :==: (-fromRational b - sqD) / (2 * fromRational a)
+                     ]
+   return $ addToClipboard "a" (fromRational a)
+          $ addToClipboard "b" (fromRational b)
+          $ addToClipboard "c" (fromRational c)
+          $ addToClipboard "D" (fromRational discr)
+          $ replaceInContext eqs cor
+
+higherSubst :: Rule (Context (Equation Expr))
+higherSubst = describe "Substitute variable" $
+   ruleMaybe (polyeq, "subst") $ \ceq -> do
+      lhs :==: rhs <- fromContext ceq
+      guard (rhs == 0)
+      let myView = polyView >>> second trinomialPolyView
+      (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs
+      guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p")
+      let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2)))
+      return $ addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2))
+             $ replaceInContext (new :==: 0) ceq
+
+substBackVar :: Rule (Context Expr)
+substBackVar = describe "Substitute back a variable" $
+   makeRule (polyeq, "back-subst") $ \ca -> do
+   a    <- fromContext ca
+   expr <- lookupClipboard "subst" ca
+   case fromExpr expr of
+      Just (Var p :==: rhs) -> do
+         guard (hasVar p a)
+         return (replaceInContext (subst p rhs a) ca)
+      _ -> fail "no subst in clipboard"
+ where
+   subst a b (Var c) | a==c = b
+   subst a b expr = descend (subst a b) expr
+
+exposeSameFactor :: Rule (Equation Expr)
+exposeSameFactor = describe "expose same factor" $
+   liftView (bothSidesView (toView productView)) $
+   makeRule (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do
+      (nx, ny) <- [ (xs, new) | x <- xs, isOk x, new <- exposeList x ys ] ++
+                  [ (new, ys) | y <- ys, isOk y, new <- exposeList y xs ]
+      return ((bx, nx) :==: (by, ny))
+ where
+   isOk p = fromMaybe False $ do
+      (_, _, b) <- match (linearViewWith rationalView) p
+      guard (b /= 0)
+      return True
+
+   exposeList _ [] = []
+   exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs)
+
+   expose a b = do
+      (s1, p1) <- matchM (polyViewWith rationalView) a
+      (s2, p2) <- matchM (polyViewWith rationalView) b
+      guard (s1==s2 && p1/=p2)
+      case safeDiv p2 p1 of
+         Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3]
+         Nothing -> []
+
+---------------------------------------------------------
+-- From LinearEquations
+
+-- Only used for cleaning up
+distributeAll :: Expr -> Expr
+distributeAll expr =
+   case expr of
+      e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1)
+                       bs = fromMaybe [e2] (match sumView e2)
+                   in build sumView [ a .*. b | a <- as, b <- bs ]
+      _ -> expr
+
+-- This rule should consider the associativity of multiplication
+-- Combine bottom-up, for example:  5*(x-5)*(x+5)
+-- However, in  -2x(2x+10)   (-2x) should be seen as "one term"
+distribution :: Expr -> [Expr]
+distribution expr = do
+   (b, xs) <- matchM simpleProductView expr
+   ys      <- rec (combine xs)
+   return $ build simpleProductView (b, ys)
+ where
+   combine :: [Expr] -> [Expr]
+   combine (x:y:rest) | p x && p y = combine ((x*y):rest)
+    where p = maybe False ((==1) . length) . match sumView
+   combine []     = []
+   combine (x:xs) = x : combine xs
+
+   rec :: [Expr] -> [[Expr]]
+   rec (a:b:xs) = map (:xs) (g a b) ++ map (a:) (rec (b:xs))
+   rec _        = []
+
+   g :: Expr -> Expr -> [Expr]
+   g e1 e2 = do
+      as <- matchM sumView e1
+      bs <- matchM sumView e2
+      guard (length as > 1 || length bs > 1)
+      return $ build sumView [ a .*. b | a <- as, b <- bs ]
+
+-------------------------------------------------------
+-- Rewrite Rules
+
+varToLeft :: Rule (Relation Expr)
+varToLeft = doAfter (fmap collectLikeTerms) $
+   describe "variable to left" $
+   ruleTrans (lineq, "var-left") $
+   inputWith arg minusRule 
+ where
+   arg = transMaybe $ \eq -> do
+      (x, a, _) <- matchM (linearViewWith rationalView) (rightHandSide eq)
+      guard (a/=0)
+      return (fromRational a * Var x)
+
+-- factor is always positive due to lcm function
+removeDivision :: Rule (Relation Expr)
+removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $
+   describe "remove division" $
+   ruleTrans (lineq, "remove-div") $
+   inputWith arg timesRule 
+ where
+   arg = transMaybe $ \eq -> do
+      xs <- matchM sumView (leftHandSide eq)
+      ys <- matchM sumView (rightHandSide eq)
+      -- also consider parts without variables
+      -- (but at least one participant should have a variable)
+      zs <- forM (xs ++ ys) $ \a -> do
+               (_, list) <- matchM productView a
+               return [ (hasSomeVar a, e) | e <- list ]
+      let f (b, e) = do
+             (_, this) <- match (divView >>> second integerView) e
+             return (b, this)
+          (bs, ns) = unzip (mapMaybe f (concat zs))
+      guard (or bs)
+      return (fromInteger (foldr1 lcm ns))
+
+distributeTimes :: Rule Expr
+distributeTimes = describe "distribution multiplication" $
+   makeRule (lineq, "distr-times") $
+      fmap collectLikeTerms . distribution
+
+distributeDivisionMulti :: IsTerm a => Rule (Context a)
+distributeDivisionMulti = describe "distribution division" $
+   makeRule (quadreq, "distr-div") $ apply $ repeat1 $
+      somewhere (use (makeRule () distributeDivisionT))
+
+distributeDivisionT :: Expr -> Maybe Expr
+distributeDivisionT expr = do
+   (xs, r) <- match (divView >>> (toView sumView *** rationalView)) expr
+   guard (length xs > 1)
+   let ys = map (/fromRational r) xs
+   return $ build sumView ys
+
+merge :: Rule Expr
+merge = describe "merge similar terms" $
+   ruleMaybe (lineq, "merge") $ \old -> do
+      let norm = cleanUpSimple old -- don't use rule just for cleaning up
+          new  = collectLikeTerms norm
+          f    = maybe 0 length . match sumView
+      guard (f norm > f new)
+      return new
+
+simplerLinearFactor :: Rule Expr
+simplerLinearFactor = describe "simpler linear factor" $
+   makeRule (polyeq, "simpler-linfactor") $ \expr -> do
+   let myView = polyNormalForm rationalView >>> second linearPolyView
+   (x, (a, b)) <- match myView expr
+   let d = (if a<0 then negate else id) (gcdFrac a b)
+   guard (a /= 0 && b /= 0 && d `notElem` [1, -1])
+   return $ fromRational d * build myView (x, (a/d, b/d))
+
+ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a
+ruleFromView s v = makeRule s $ \a -> do
+   b <- canonical v a
+   guard (a /= b)
+   return b
+
+rhsIsZero :: Rule Expr -> Rule (Equation Expr)
+rhsIsZero r = makeRule (showId r) $ \(lhs :==: rhs) -> do
+   guard (rhs == 0)
+   a <- applyAll r lhs
+   return (a :==: rhs)
+
+constantRight :: View Expr a -> View (Equation Expr) (a, Rational)
+constantRight v = makeView f g
+ where
+   f (lhs :==: rhs) = (,) <$> match v lhs <*> match rationalView rhs
+   g (a, r) = build v a :==: build rationalView r
+
+bothSidesView :: View a b -> View (Equation a) (Equation b)
+bothSidesView v = makeView f (fmap (build v))
+ where
+   f (lhs :==: rhs) = (:==:) <$> match v lhs <*> match v rhs
+
+findFactor :: Monad m => [Rational] -> m Rational
+findFactor rs
+   | null rs =
+        fail "no factor"
+   | all ((==1) . denominator) rs =
+        return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs
+   | otherwise =
+        return $ fromIntegral $ foldr1 lcm $ map denominator rs
+
+noDivisionConstant :: Rule Expr
+noDivisionConstant = makeRule (lineq, "no-div-con") f
+ where
+   f (a :/: b) | hasNoVar b && hasSomeVar a =
+      return ((1/b) * a)
+   f _ = Nothing
+
+-- (a/b) * (c/d) = (a*c)/(b*d)
+fractionProduct :: Rule Expr
+fractionProduct = makeRule (polyeq, "fraction-product") $ \expr -> do
+   ((a, b), (c, d)) <- match (timesView >>> divView *** divView) expr
+   return ((a .*. c) ./. (b .*. d))
+
+defPowerNat :: Rule Expr
+defPowerNat = makeRule (polyeq, "def-power-nat") f
+ where
+   f (Sym _ [Var _, _]) = Nothing -- should not work on x^5
+   f (Sym s [a, Nat n]) | isPowerSymbol s =
+      return (build productView (False, replicate (fromInteger n) a))
+   f _ = Nothing
+ src/Domain/Math/Polynomial/Views.hs view
@@ -0,0 +1,333 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Polynomial.Views
+   ( polyView, polyViewWith
+   , quadraticView, quadraticViewWith
+   , linearView, linearViewWith
+   , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView
+   , monomialPolyView, binomialPolyView, trinomialPolyView
+   , polyNormalForm, polyRelaxedForm
+   , linearEquationView, quadraticEquationView, quadraticEquationsView
+   , higherDegreeEquationsView, listOfPowerFactors
+   ) where
+
+import Control.Monad
+import Data.Foldable (toList)
+import Data.Maybe
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.OldViews (powerFactorViewForWith)
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Classes
+import Ideas.Common.Rewriting
+import Ideas.Utils.Prelude (distinct)
+import Ideas.Utils.Uniplate (transform, descend, children)
+import Ideas.Common.View
+import Prelude hiding ((^))
+import qualified Domain.Math.Data.SquareRoot as SQ
+import qualified Prelude
+
+polyViewWithNew :: View (String, Expr) (String, Polynomial Expr)
+polyViewWithNew = makeView matchPoly buildPoly
+ where
+   matchPoly (s, expr) = ((,) s) <$> matchPolyFor s expr
+   buildPoly (s, p)    = (s, buildPolyFor s p)
+
+   matchPolyFor pv expr =
+      case expr of
+         Var s | pv == s -> Just var
+         Nat n    -> Just (fromIntegral n)
+         Negate a -> negate <$> f a
+         a :+: b  -> (+) <$> f a <*> f b
+         a :-: b  -> (-) <$> f a <*> f b
+         a :*: b  -> (*) <$> f a <*> f b
+         a :/: b  -> do
+            guard (withoutVar pv b)
+            p <- f a
+            d <- match rationalApproxView b
+            guard (d /= 0)
+            return (fmap (/fromRational d) p)
+         Sym s [a, n] | isPowerSymbol s ->
+            (Prelude.^) <$> f a <*> matchNat n
+         _ -> do
+            guard (withoutVar pv expr)
+            return (con expr)
+    where
+      f = matchPolyFor pv
+
+   buildPolyFor pv =
+      let f (a, n) = a .*. (Var pv .^. fromIntegral n)
+      in build sumView . map f . reverse . terms
+
+   matchNat expr = do
+      n <- match integerView expr
+      guard (n >= 0)
+      return n
+
+-------------------------------------------------------------------
+-- Polynomial view
+
+polyView :: View Expr (String, Polynomial Expr)
+polyView = (f <-> snd) >>> polyViewWithNew
+ where
+   f a = (fromMaybe "" (selectVar a), a)
+
+polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a)
+polyViewWith v = polyView >>> second (traverseView v)
+
+-------------------------------------------------------------------
+-- Quadratic view
+
+quadraticView :: View Expr (String, Expr, Expr, Expr)
+quadraticView = quadraticViewWith identity
+
+quadraticViewWith :: (Eq a,Fractional a) => View Expr a -> View Expr (String, a, a, a)
+quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> (f <-> g)
+ where
+   f (s, (a, b, c)) = (s, a, b, c)
+   g (s, a, b, c)   = (s, (a, b, c))
+
+-------------------------------------------------------------------
+-- Linear view
+
+linearView :: View Expr (String, Expr, Expr)
+linearView = linearViewWith identity
+
+linearViewWith :: (Eq a,Fractional a) => View Expr a -> View Expr (String, a, a)
+linearViewWith v = polyViewWith v >>> second linearPolyView >>> (f <-> g)
+ where
+   f (s, (a, b)) = (s, a, b)
+   g (s, a, b)   = (s, (a, b))
+
+-------------------------------------------------------------------
+-- Views on polynomials (degree)
+
+constantPolyView :: (Eq a,Num a) => View (Polynomial a) a
+constantPolyView = makeView (isList1 . fromPolynomial) (buildList . list1)
+
+linearPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a)
+linearPolyView = makeView (isList2 . fromPolynomial) (buildList . list2)
+
+quadraticPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a, a)
+quadraticPolyView = makeView (isList3 . fromPolynomial) (buildList . list3)
+
+cubicPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a, a, a)
+cubicPolyView = makeView (isList4 . fromPolynomial) (buildList . list4)
+
+-------------------------------------------------------------------
+-- Views on polynomials (number of terms)
+
+monomialPolyView :: (Eq a,Num a) => View (Polynomial a) (a, Int)
+monomialPolyView = makeView (isList1 . terms) (buildPairs . list1)
+
+binomialPolyView :: (Eq a,Num a) => View (Polynomial a) ((a, Int), (a, Int))
+binomialPolyView = makeView (isList2 . terms) (buildPairs . list2)
+
+trinomialPolyView :: (Eq a,Num a) => View (Polynomial a) ((a, Int), (a, Int), (a, Int))
+trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3)
+
+-- helpers
+buildList :: (Eq a,Num a) => [a] -> Polynomial a
+buildList = buildPairs . flip zip [0..] . reverse
+
+buildPairs :: (Eq a,Num a) => [(a, Int)] -> Polynomial a
+buildPairs as
+   | null as   = 0
+   | otherwise = sum (map f as)
+ where
+   f (a, n) = con a * var Prelude.^ n
+
+list1 :: a -> [a]
+list1 a = [a]
+
+list2 :: (a, a) -> [a]
+list2 (a, b)     = [a, b]
+
+list3 :: (a, a, a) -> [a]
+list3 (a, b, c) = [a, b, c]
+
+list4 :: (a, a, a, a) -> [a]
+list4 (a, b, c, d) = [a, b, c, d]
+
+isList1 :: [a] -> Maybe a
+isList1 [a] = Just a
+isList1 _   = Nothing
+
+isList2 :: [a] -> Maybe (a, a)
+isList2 [a, b] = Just (a, b)
+isList2 _      = Nothing
+
+isList3 :: [a] -> Maybe (a, a, a)
+isList3 [a, b, c] = Just (a, b, c)
+isList3 _         = Nothing
+
+isList4 :: [a] -> Maybe (a, a, a, a)
+isList4 [a, b, c, d] = Just (a, b, c, d)
+isList4 _            = Nothing
+
+terms :: (Eq a,Num a) => Polynomial a -> [(a, Int)]
+terms = filter ((/=0) . fst) . flip zip [0..] . reverse . fromPolynomial
+
+-------------------------------------------------------------------
+-- Normal form, and list of power factors
+
+listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)]
+listOfPowerFactors pv v =
+   toView sumView >>> listView (powerFactorViewForWith pv v)
+
+-- Generalization
+polyForm :: (Eq a,Num a) => Bool -> View Expr a -> View Expr (String, Polynomial a)
+polyForm relaxed v = makeView f (uncurry g)
+ where
+   f e = do
+      pv <- selectVar e
+      xs <- match (listOfPowerFactors pv v) e
+      guard (relaxed || distinct (map snd xs))
+      return (pv, buildPairs xs)
+   g pv = build (listOfPowerFactors pv v) . reverse . terms
+
+polyNormalForm :: (Eq a,Num a) => View Expr a -> View Expr (String, Polynomial a)
+polyNormalForm = polyForm False
+
+-- relaxes the condition that all powers should be distinct
+polyRelaxedForm :: (Eq a,Num a) => View Expr a -> View Expr (String, Polynomial a)
+polyRelaxedForm = polyForm True
+
+-------------------------------------------------------------------
+-- Normal forms for equations
+
+-- Excludes equations such as 1==1 or 0==1
+linearEquationViewWith :: (Eq a,Fractional a) => View Expr a -> View (Equation Expr) (String, a)
+linearEquationViewWith v = makeView f g
+ where
+   f (lhs :==: rhs) = do
+      (x, a, b) <- match (linearViewWith v) (lhs - rhs)
+      return (x, -b/a)
+   g (x, r) = Var x :==: build v r
+
+linearEquationView :: View (Equation Expr) (String, Rational)
+linearEquationView = linearEquationViewWith rationalApproxView
+
+quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational))
+quadraticEquationsView = makeView f (fmap g)
+ where
+   f = fmap (simplify orSetView . foldMap id)
+          . mapM (match quadraticEquationView)
+
+   g (x, a) = Var x :==: build (squareRootViewWith rationalApproxView) a
+
+quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational))
+quadraticEquationView = makeView f g
+ where
+   f (lhs :==: rhs) = do
+      (s, p) <- match (polyViewWith (squareRootViewWith rationalApproxView)) (lhs - rhs)
+      guard (degree p <= 2)
+      fmap (fmap ((,) s)) $
+         case fromPolynomial p of
+            [a, b, c] -> do
+               discr <- SQ.fromSquareRoot (b*b - SQ.scale 4 (a*c))
+               let sdiscr = SQ.sqrtRational discr
+                   twoA   = SQ.scale 2 a
+               case compare discr 0 of
+                  LT   -> return false
+                  EQ   -> return $ singleton (-b/twoA)
+                  GT   -> return $ toOrList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA]
+            [a, b]     -> return $ singleton (-b/a)
+            [a] | a==0 -> return true
+            _          -> return false
+
+   g xs | isTrue xs = 0 :==: 0
+        | otherwise = build productView (False, map make (toList xs)) :==: 0
+    where
+      make (x, a) = Var x .-. build (squareRootViewWith rationalApproxView) a
+
+higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr)
+higherDegreeEquationsView = f <-> fmap (:==: 0)
+ where
+   f    = simplify orSetView . foldMap make . coverUpOrs
+   make = toOrList . filter (not . hasNegSqrt)
+        . map (cleanUpExpr . distr) . normHDE . sub
+   sub (a :==: b) = a-b
+
+   distr = transform g
+    where
+      g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c)
+      g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c)
+      g a = a
+
+hasNegSqrt :: Expr -> Bool
+hasNegSqrt (Sqrt a) =
+   case match rationalApproxView a of
+      Just r | r < 0 -> True
+      _ -> hasNegSqrt a
+hasNegSqrt (Sym s [a, b]) | isRootSymbol s =
+   case (match rationalApproxView a, match integerView b) of
+      (Just r, Just n) | r < 0 && even n -> True
+      _ -> hasNegSqrt a || hasNegSqrt b
+hasNegSqrt a =
+   any hasNegSqrt (children a)
+
+normHDE :: Expr -> [Expr]
+normHDE e =
+   case match (polyViewWith rationalApproxView) e of
+      Just (x, p)  -> normPolynomial x p
+      Nothing -> fromMaybe [e] $ do
+         (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalApproxView)) (e :==: 0)
+         return [ Var x .+. build (squareRootViewWith rationalApproxView) (-a) ]
+
+normPolynomial :: String -> Polynomial Rational -> [Expr]
+normPolynomial x p
+   | degree p == 0 =
+        []
+   | length (terms p) <= 1 =
+        [Var x]
+   | degree p == 1 =
+        [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)]
+   | degree p == 2 =
+        let [a,b,c] = [ coefficient n p | n <- [2,1,0] ]
+            discr   = b*b - 4*a*c
+            sdiscr  = SQ.sqrtRational discr
+        in if discr < 0 then [] else
+           map ((Var x .+.) . build (squareRootViewWith rationalApproxView))
+           [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)
+           , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)
+           ]
+   | otherwise =
+        case terms p of
+           [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 ->
+              let list = [(c, 0), (b, 1), (a, e2 `div` e1)]
+                  newp = sum (map (\(y, z) -> con y * (var Prelude.^ z)) list)
+                  sub  = map (substitute (x, Var x^fromIntegral e1))
+              in concatMap normHDE (sub (normPolynomial x newp))
+           [(c, 0), (a, n)]
+              | odd n  -> if c/a >= 0
+                          then [Var x + root (fromRational (c/a)) (fromIntegral n)]
+                          else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)]
+              | even n -> if c/a > 0
+                          then []
+                          else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n)
+                               , Var x - root (fromRational (abs (c/a))) (fromIntegral n)
+                               ]
+           _ ->
+              case factorize p of
+                 ps | length ps > 1 -> concatMap (normPolynomial x) ps
+                 _ -> [build (polyViewWith rationalApproxView) (x, p)]
+
+substitute :: (String, Expr) -> Expr -> Expr
+substitute (s, a) (Var b) | s==b = a
+substitute pair expr = descend (substitute pair) expr
+ src/Domain/Math/Power/OldViews.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Power.OldViews
+   ( powerFactorView, powerFactorViewForWith, powerFactorViewWith
+   ) where
+
+import Control.Monad
+import Domain.Math.Expr hiding ( (^) )
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+
+powerFactorView :: View Expr (String, Expr, Int)
+powerFactorView = powerFactorViewWith identity
+
+powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int)
+powerFactorViewWith v = makeView f g
+ where
+   f expr = do
+      pv <- selectVar expr
+      (e, n) <- match (powerFactorViewForWith pv v) expr
+      return (pv, e, n)
+   g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n)
+
+powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int)
+powerFactorViewForWith pv v = makeView f g
+ where
+   f expr =
+      case expr of
+         Var s | pv == s -> Just (1, 1)
+         Negate e -> do
+            (a, b) <- f e
+            return (negate a, b)
+         e1 :*: e2 -> do
+            (a1, b1) <- f e1
+            (a2, b2) <- f e2
+            return (a1*a2, b1+b2)
+         Sym s [e1, Nat n]
+            | isPowerSymbol s -> do
+                 (a1, b1) <- f e1
+                 a <- match v (build v a1 ^ toInteger n)
+                 return (a, b1 * fromInteger n)
+         _ -> do
+            guard (withoutVar pv expr)
+            a <- match v expr
+            return (a, 0)
+
+   g (a, b) = build v a .*. (Var pv .^. fromIntegral b)
+ src/Domain/Math/Power/Rules.hs view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Power.Rules
+  ( -- * Power rules
+    calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents
+  , subExponents, distributePower, distributePowerDiv, reciprocal
+  , reciprocalInv, reciprocalFrac, calcPowerRatio, simplifyPower
+  , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar
+  , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents
+    -- * Root rules
+  , power2root, root2power
+    -- * Log rules
+  , logarithm
+    -- * Common rules
+  , myFractionTimes, pushNegOut
+  ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Utils
+import Domain.Math.Power.Views
+import Ideas.Common.Library hiding ((.*.), (./.))
+import Prelude hiding ( (^) )
+import qualified Domain.Math.Data.PrimeFactors as PF
+import qualified Prelude
+
+-- Identifier prefixes ------------------------------------------------------
+
+power, logarithmic :: String
+power       = "algebra.manipulation.exponents"
+logarithmic = "algebra.manipulation.logarithmic"
+
+-- Power rules --------------------------------------------------------------
+
+-- | n  =>  a^e  (with e /= 1)
+factorAsPower :: Rule Expr
+factorAsPower = ruleList (power, "factor-as-power") $ \ expr -> do
+  n      <- matchM myIntegerView expr
+  (a, x) <- PF.allPowers $ toInteger n
+  if n > 0
+    then return $ fromInteger a .^. fromInteger x
+    else if odd x
+      then return $ fromInteger (negate a) .^. fromInteger x
+      else fail "Could not factorise number."
+
+-- | Calculate power, e.g., 2^2 => 4
+calcPower :: Rule Expr
+calcPower = makeRule "arithmetic.operation.rational.power" $ \ expr -> do
+  (a, x) <- match (powerViewWith rationalView plainNatView) expr
+  return $ fromRational $ a Prelude.^ x
+
+-- | a^(x/y) => (a^x)^(1/y)
+calcPowerRatio :: Rule Expr
+calcPowerRatio = makeRule (power, "power-ratio") $ \ expr -> do
+  let v = powerView >>> second (rationalView >>> plainRationalView)
+  (a, (x, y)) <- match v expr
+  guard $ x /= 1 && y /= 1
+  return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y)
+
+-- | root n x
+calcPlainRoot :: Rule Expr
+calcPlainRoot = makeRule (power, "root") $ \expr -> do
+   (n, x) <- matchM (rootView >>> (integerView *** integerView)) expr
+   fmap fromInteger (takeRoot n x)
+
+-- | [root n x, ... ]
+-- BHR: not used. Better to turn this into OrList (Relation Expr)
+{-
+calcRoot :: Rule (OrList Expr)
+calcRoot = makeRule (power, "root") $
+   oneDisjunct $ \expr -> do
+      (n, x) <- match (rootView >>> (integerView *** integerView)) expr
+      y      <- fmap fromInteger $ lookup n $ map swap $ PF.allPowers (abs x)
+      let ys | x > 0 && even n = [y, negate y]
+             | x > 0 && odd  n = [y]
+             | x < 0 && odd  n = [negate y]
+             | otherwise       = []
+      roots  <- toMaybe (not. null) ys
+      return $ toOrList roots
+-}
+
+calcPowerPlus :: Rule Expr
+calcPowerPlus =
+  makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus
+
+calcPowerMinus :: Rule Expr
+calcPowerMinus =
+   makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus
+
+addExponents :: Rule Expr
+addExponents = ruleList (power, "add-exponents") $ \ expr -> do
+  (sign, fs)     <- matchM (powerFactorView isPow) expr
+  ((x, y), fill) <- twoNonAdjacentHoles fs
+  prod           <- applyM simpleAddExponents $ x * y
+  return $ build productView (sign, fill prod)
+
+isPow :: Expr -> Expr -> Bool
+isPow x y = x `belongsTo` myIntegerView &&
+             (y `belongsTo` variableView || y `belongsTo` powerView)
+
+-- | a*x^y * b*x^q = a*b * x^(y+q)
+simpleAddExponents :: Rule Expr
+simpleAddExponents = makeRule (power, "simple-add-exponents") $ \expr -> do
+  (e1, e2)     <- match timesView expr
+  (a, (x,  y)) <- match unitPowerView e1
+  (b, (x', q)) <- match unitPowerView e2
+  guard $ x == x'
+  return $ build unitPowerView (a .*. b, (x, y .+. q))
+
+-- | a*x^y / b*x^q = a/b * x^(y-q)
+subExponents :: Rule Expr
+subExponents = makeRule (power, "sub-exponents") $ \ expr -> do
+  (e1, e2)     <- match divView expr
+  (a, (x,  y)) <- match unitPowerView e1
+  (b, (x', q)) <- match unitPowerView e2
+  guard $ x == x'
+  return $ build unitPowerView (a ./. b, (x, y .-. q))
+
+-- | (a^x)^y = a^(x*y)
+mulExponents :: Rule Expr
+mulExponents = makeRule (power, "mul-exponents") $ \ expr -> do
+  ((a, x), y) <- match (strictPowerView >>> first powerView) expr
+  return $ build powerView (a, x .*. y)
+
+-- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x
+distributePower :: Rule Expr
+distributePower = makeRule (power, "distr-power") $ \ expr -> do
+  ((sign, as), x) <- match (powerViewWith (toView productView) identity) expr
+  guard $ length as > 1
+  let y = build productView (False, map (\a -> build powerView (a, x)) as)
+  return $
+    maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x
+
+-- | (a/b)^y = (a^y / b^y)
+distributePowerDiv :: Rule Expr
+distributePowerDiv = makeRule (power, "distr-power-div") $ \ expr -> do
+  ((a, b), y) <- match (powerViewWith divView identity) expr
+  return $ build divView (build powerView (a, y), build powerView (b, y))
+
+-- | a^0 = 1
+zeroPower :: Rule Expr
+zeroPower = makeRule (power, "power-zero") $ \ expr -> do
+  (_, x) <- match powerView expr
+  guard $ x == 0
+  return 1
+
+-- a ^ 1 = a
+onePower :: Rule Expr
+onePower = makeRule (power, "power-one") $ \ expr -> do
+  (a, x) <- match powerView expr
+  guard $ x == 1
+  return a
+
+-- 1 ^ x = 1
+powerOne :: Rule Expr
+powerOne = makeRule (power, "one-power") $ \ expr -> do
+  (a, _) <- match powerView expr
+  guard $ a == 1
+  return a
+
+-- 0 ^ x = 0 with x > 0
+powerZero :: Rule Expr
+powerZero = makeRule (power, "one-power") $ \ expr -> do
+  (a, x) <- match (powerViewWith identity integerView) expr
+  guard $ x > 0 && a == 0
+  return 0
+
+-- | all of the above simplification rules
+simplifyPower :: Rule Expr
+simplifyPower = ruleList (power, "simplify") $ \ expr ->
+  mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero]
+
+-- | e/a = e*a^(-1)  where a is an variable
+reciprocalVar :: Rule Expr
+reciprocalVar = makeRule (power, "reciprocal-var") $ \ expr -> do
+  (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr
+  return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c
+
+-- | c/a^x = c*a^x^(-1)
+reciprocalPower :: Rule Expr
+reciprocalPower = makeRule (power, "reciprocal-power") $ \ expr -> do
+  (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr
+  return $ (e .*. build consPowerView (1, (a, neg x))) ./. c
+
+-- | Use with care, will match any fraction!
+reciprocal :: Rule Expr
+reciprocal = makeRule (power, "reciprocal") $ \expr -> do
+  (a, b) <- match divView expr
+  return $ a .*. build powerView (b, -1)
+
+-- | a^x = 1/a^(-x)
+reciprocalInv ::  Rule Expr
+reciprocalInv = makeRule (power, "reciprocal-inverse") $ \ expr -> do
+  guard $ hasNegExp expr
+  (a, x) <- match strictPowerView expr
+  return $ 1 ./. build strictPowerView (a, neg x)
+
+-- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r...
+reciprocalFrac :: Rule Expr
+reciprocalFrac = makeRule (power, "reciprocal-frac") $ \ expr -> do
+  (e1, e2) <- match divView expr
+  (s, xs)  <- match productView e2
+  let (ys, zs) = partition hasNegExp xs
+  guard (not $ null ys)
+  return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs)
+    where
+      f e = case match consPowerView e of
+              Just (c, (a, x)) -> build consPowerView (c, (a, neg x))
+              Nothing          -> e
+
+-- | a^x / b^x = (a/b)^x
+divBase :: Rule Expr
+divBase = describe "divide base of root" $
+  makeRule (power, "divide-base") $ \ expr -> do
+  (e1, e2)      <- match divView expr
+  (c1, (a, x))  <- match consPowerView e1
+  (c2, (b, x')) <- match consPowerView e2
+  guard $ x == x' && b /= 0
+  return $ build consPowerView (c1 .*. c2, (a ./. b, x))
+
+-- | (-a)^x = -(a^x)
+pushNegOut :: Rule Expr
+pushNegOut = makeRule (power, "push-negation-out") $ \ expr -> do
+  (a, x) <- match (powerViewWith identity integerView) expr
+  a'     <- isNegate a
+  return $ (if odd x then neg else id) $ build powerView (a', fromInteger x)
+
+-- | Root rules ----------------------------------------------------------------
+
+-- | a^(p/q) = root (a^p) q
+power2root :: Rule Expr
+power2root = makeRule (power, "write-as-root") $ \ expr -> do
+  (a, (p, q)) <- match (strictPowerView >>> second divView) expr
+  guard $ q /= 1
+  return $ root (a .^. p) q
+
+-- | root a q = a^(1/q)
+root2power :: Rule Expr
+root2power = makeRule (power, "write-as-power") $ \ expr -> do
+  (a, q) <- match strictRootView expr
+  return $ a .^. (1 ./. q)
+
+-- | Logarithmic relation rules -----------------------------------------------
+
+logarithm :: Rule (Equation Expr)
+logarithm = makeRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do
+    (b, x) <- match logView lhs
+    return $ x :==: build powerView (b, rhs)
+
+-- | Common rules --------------------------------------------------------------
+
+-- | a/b * c/d = a*c / b*d  (b or d may be one)
+myFractionTimes :: Rule Expr
+myFractionTimes = smartRule $ makeRule (power, "fraction-times") $ \ expr -> do
+  (e1, e2) <- match timesView expr
+  guard $ e1 `belongsTo` divView || e2 `belongsTo` divView
+  let f e    = fromMaybe (e, 1) (match divView e)
+      (a, b) = f e1
+      (c, d) = f e2
+  return $ build divView (a .*. c, b .*. d)
+
+-- | Help functions -----------------------------------------------------------
+
+calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr
+calcBinPowerRule opName op m =
+  makeRule (power, "calc-power", opName) $ \e -> do
+    (e1, e2)     <- m e
+    (c1, (a, x)) <- match unitPowerViewVar e1
+    (c2, (b, y)) <- match unitPowerViewVar e2
+    guard $ a == b && x == y
+    return $ build unitPowerViewVar (op c1 c2, (a, x))
+
+-- use twoNonAdHoles instead of split ???
+makeCommutative :: IsView f => f Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr
+makeCommutative view op r =
+  ruleList (getId r) $ \ expr ->
+    case match view expr of
+      Just factors -> do
+        (e, es) <- split op factors
+        case apply r e of
+          Just e' -> return $ build view (e' : es)
+          Nothing -> []
+      Nothing -> []
+
+hasNegExp :: Expr -> Bool
+hasNegExp = maybe False ((< 0) . snd . snd) . match consPowerView
+ src/Domain/Math/Power/Utils.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- some of these help functions may have a broader scope and could be
+-- moved to other parts of the framework (eg. Common)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Power.Utils where
+
+import Data.Foldable (toList)
+import Data.Function (on)
+import Data.List
+import Data.Ratio
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Rules
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library hiding ((.*.), (./.))
+import Ideas.Utils.Uniplate
+
+-- | Strategy functions -------------------------------------------------------
+
+exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a)
+exhaustiveStrategy = exhaustiveSomewhere . map liftToContext
+
+exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b)
+exhaustiveUse = exhaustiveSomewhere . map use
+
+exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a)
+exhaustiveSomewhere = repeatS . somewhere . alternatives
+
+-- | Rule functions -----------------------------------------------------------
+
+smartRule :: Rule Expr -> Rule Expr
+smartRule = doAfter f
+  where
+    f (a :*: b) = a .*. b
+    f (a :/: b) = a ./. b
+    f (Negate a) = neg a
+    f (a :+: b) = a .+. b
+    f (a :-: b) = a .-. b
+    f e = e
+
+mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr
+mergeConstantsWith p = simplifyWith f productView
+  where
+    f (sign, xs) =
+      let (cs, ys) = partition p xs
+          c = simplify rationalView $ build productView (False, cs)
+      in if maybe False (> 1) (match rationalView c)
+           then (sign, c:ys)
+           else (sign, xs)
+
+mergeConstants :: Expr -> Expr
+mergeConstants = mergeConstantsWith (`belongsTo` rationalView)
+
+-- | View functions -----------------------------------------------------------
+
+plainNatView :: View Expr Integer
+plainNatView = makeView f Nat
+  where
+    f (Nat n) = Just n
+    f _       = Nothing
+
+myIntegerView :: View Expr Integer
+myIntegerView = makeView f fromInteger
+  where
+    f (Nat n)          = Just n
+    f (Negate (Nat n)) = Just $ negate n
+    f _                = Nothing
+
+plainRationalView :: View Rational (Integer, Integer)
+plainRationalView =
+  makeView (\x -> return (numerator x, denominator x)) (uncurry (%))
+
+eqView :: View a b -> View (Equation a) (b, b)
+eqView v = eqv >>> v *** v
+  where
+    eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:))
+
+relationView :: View (Equation a) (Relation a)
+relationView = makeView f g
+ where
+   f (x :==: y) = return $ x .==. y
+   g r | relationType r == EqualTo = leftHandSide r :==: rightHandSide r
+       | otherwise                 = error "Not an equality"
+
+-- | Rule collections ---------------------------------------------------------
+
+naturalRules :: [Rule Expr]
+naturalRules =
+   [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView
+   , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView
+   , doubleNegate, negateZero , plusNegateLeft, plusNegateRight
+--   , minusNegateLeft
+   , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft
+   , divisionNegateRight
+   ]
+
+rationalRules :: [Rule Expr]
+rationalRules =
+   [ calcPlusWith "rational" rationalRelaxedForm
+   , calcMinusWith "rational" rationalRelaxedForm
+   , calcTimesWith "rational" rationalRelaxedForm
+   , calcDivisionWith "integer" integerNF
+   , doubleNegate, negateZero, divisionDenominator, divisionNumerator
+   , simplerFraction
+   ]
+
+coverUpRulesX :: [Rule (Equation Expr)]
+coverUpRulesX = map (\r -> r cfg)
+   [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith, coverUpNegateWith
+   , coverUpTimesWith, coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
+   ]
+   where
+     cfg = configCoverUp { predicateCovered = elem "x" . vars
+                         , predicateCombined = notElem "x" . vars
+                         , coverLHS = False}
+
+-- | Common functions ---------------------------------------------------------
+
+sortExpr :: Expr -> Expr
+sortExpr = transform $ simplifyWith (sort . map sortProd) sumView
+  where sortProd = simplifyWith (fmap sort) productView
+
+sortEquation :: Equation Expr -> Equation Expr
+sortEquation (x :==: y) = if x < y then eq else flipSides eq
+  where eq = sortExpr x :==: sortExpr y
+
+sortOrList :: OrList (Equation Expr) -> OrList (Equation Expr)
+sortOrList = toOrList . sort . map sortEquation . toList
+
+-- Semantic equivalence
+class SemEq a where
+    (===), (=/=) :: a -> a -> Bool
+    x =/= y = not (x === y)
+--    x === y = not (x =/= y)
+
+infix 4 ===, =/=
+
+instance SemEq a => SemEq (Equation a) where
+  (a :==: b) === (c :==: d) = a === c && b === d || a === d && b === c
+
+instance SemEq Expr where
+  (===) = on (==) cleanUpExpr
+
+instance SemEq a => SemEq (OrList a) where
+  a === b = let as = toList a ; bs = toList b
+            in length (intersectBy (===) as bs) == length as
+
+-- y = root n x
+takeRoot :: Integer -> Integer -> Maybe Integer
+takeRoot n x
+   | n >= 0 && x >0 && a Prelude.^ x == n = Just a
+   | otherwise = Nothing
+ where
+   a = round (fromInteger n ** (1/fromInteger x) :: Double)
+{-
+| n == 0    = [0]
+             | n == 1    = if x > 0 && odd x then [1] else [1, -1]
+             | n == (-1) = [-1 | x > 0 && odd x]
+             | x == 1    = [n]
+             | x > 0     = maybe [] roots $ lookup x $ map swap $ PF.allPowers (abs n)
+             | otherwise = []
+  where
+    roots r | n > 0 && even x = [r, negate r]
+            | n > 0 && odd  x = [r]
+            | n < 0 && odd  x = [negate r]
+            | otherwise       = [] -}
+
+-- prop_takeRoot n = traceShow n f
+--   where
+--     f n x | x > 0 = n `elem` (takeRoot (n Prelude.^ x) x)
+--           | otherwise = True
+
+swap :: (a, b) -> (b, a)
+swap (a, b) = (b, a)
+
+split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])]
+split op xs = f xs
+      where
+        f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys
+                 | otherwise     = []
+        f [] = []
+
+toMaybe :: (a -> Bool) -> a -> Maybe a
+toMaybe p x = if p x then Just x else Nothing
+
+joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]]
+joinBy _  [] = []
+joinBy eq xs = ys : joinBy eq (xs \\ ys)
+  where
+    ys = dropUntil eq xs
+
+dropUntil :: (a -> a -> Bool) -> [a] -> [a]
+dropUntil _ []       = []
+dropUntil _ [x]      = [x]
+dropUntil p (x:y:ys) | p x y     = x : dropUntil p (y:ys)
+                     | otherwise = [x]
+
+holes :: [a] -> [(a, [a], a -> [a])]
+holes xs = map f [0 .. length xs - 1]
+  where
+    f i = let (ys, z:zs) = splitAt i xs
+          in (z, ys ++ zs, \x -> ys ++ x:zs)
+
+twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])]
+twoNonAdjacentHoles xs = concatMap g pairs
+  where
+    pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]]
+    g (x, y) = let (ys, z:zs) = splitAt x xs
+                   (ps, q:qs) = splitAt (y - x - 1) zs
+               in if null ps
+                 then [ ((z, q), \a -> ys ++ a:ps ++ qs) ]
+                 else [ ((z, q), \a -> ys ++ a:ps ++ qs)
+                      , ((z, q), \a -> ys ++ ps ++ a:qs) ]
+ src/Domain/Math/Power/Views.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Power.Views
+   ( -- * Power views
+     -- ** Simple power views
+     powerView, powerViewWith, powerViewFor, powerFactorView
+     -- ** Views for power expressions with a constant factor
+   , consPowerView
+     -- ** Power views that allow constants
+   , unitPowerView, unitPowerViewVar, strictPowerView
+     -- Root views
+   , rootView, strictRootView
+     -- * Log view
+   , logView
+     -- * Other views
+   , plainNatView, plainRationalView
+   ) where
+
+import Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Power.Utils
+import Ideas.Common.Library hiding ((./.))
+
+-- Power views with constant factor -----------------------------------------
+
+consPowerView :: View Expr (Expr, (Expr, Expr))
+consPowerView = makeView f g
+ where
+   f (Negate a) = fmap (first Negate) (f a)
+   f (a :*: b)  = fmap ((,) a) (match powerView b)
+   f expr       = f (1 :*: expr)
+   g = build (timesView >>> second powerView)
+
+unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr))
+unitPowerViewWith v = makeView f g
+ where
+   mv = powerViewWith v identity
+   f (Negate a) = fmap (first Negate) (f a)
+   f (a :*: b)  = do
+         x <- match mv b
+         return (a, x)
+       `mplus` do
+         x <- match v b
+         return (a, (x, 1))
+   f expr = f (1 :*: expr)
+   g = build (timesView >>> second mv)
+
+unitPowerViewVar :: View Expr (Expr, (String, Expr))
+unitPowerViewVar = unitPowerViewWith variableView
+
+-- | Careful! This view will match anything, so use it wise and with care.
+unitPowerView :: View Expr (Expr, (Expr, Expr))
+unitPowerView = unitPowerViewWith identity
+
+-- | A root view
+rootView :: View Expr (Expr, Expr)
+rootView = makeView f (uncurry root)
+  where
+    f expr = do
+      (a, (x, y)) <- match (powerView >>> second divView) expr
+      guard (x `elem` [1, -1])
+      return $ if x == 1 then (a, y) else (a, negate y)
+
+-- | only matches sqrt and root
+strictRootView :: View Expr (Expr, Expr)
+strictRootView = makeView f g
+  where
+    f expr =
+      case expr of
+        Sym s [a, b] | isRootSymbol s -> return (a, b)
+        Sqrt e                       -> return (e, 2)
+        _ -> Nothing
+
+    g (a, b) = if b == 2 then Sqrt a else root a b
+
+-- Power views --------------------------------------------------------------
+
+strictPowerView :: View Expr (Expr, Expr)
+strictPowerView = makeView f (uncurry (.^.))
+  where
+    f expr =
+      case expr of
+        Sym s [a, b] | isPowerSymbol s -> return (a, b)
+        _ -> Nothing
+
+powerView :: View Expr (Expr, Expr)
+powerView = matcherView f g
+  where
+    f = matcher (strictRootView >>> second (arr (1 ./.)))
+        <+> matcher strictPowerView
+    g (a, b) =
+       case b of
+         (Nat 1 :/: b') -> build strictRootView (a, b')
+         _              -> build strictPowerView (a, b)
+
+powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b)
+powerViewWith va vb = powerView >>> (va *** vb)
+
+powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b
+powerViewForWith va vb a = makeView f ((build va a .^.) .  build vb)
+  where
+    f expr = do
+      (a', b) <- match (powerViewWith va vb) expr
+      guard $ a == a'
+      return b
+
+powerViewFor :: Expr -> View Expr Expr
+powerViewFor = powerViewForWith identity identity
+
+powerFactorView :: (Expr -> Expr -> Bool) -> Isomorphism Expr (Bool, [Expr])
+powerFactorView p = productView >>> second (f <-> id)
+  where
+    f = map (build productView . (,) False) . joinBy p
+
+-- Log views ----------------------------------------------------------------
+
+logView :: View Expr (Expr, Expr)
+logView = makeView f (uncurry logBase)
+  where
+    f expr = case expr of
+        Sym s [a, b] | isLogSymbol s -> return (a, b)
+        _ -> Nothing
+ src/Domain/Math/Simplification.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.Simplification
+   ( Simplify(..), SimplifyConfig(..)
+   , simplifyConfig
+   , Simplified, simplified, liftS, liftS2
+   , simplifyRule
+   , collectLikeTerms, mergeAlike, distribution, constantFolding
+   , mergeAlikeSum, mergeAlikeProduct
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Typeable
+import Domain.Math.CleanUp (smart)
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library hiding (simplify, simplifyWith, (.*.), (./.))
+import Ideas.Utils.Uniplate
+import qualified Ideas.Common.View as View
+
+data SimplifyConfig = SimplifyConfig
+  { withSmartConstructors  :: Bool
+  , withMergeAlike         :: Bool
+  , withDistribution       :: Bool
+  , withSimplifySquareRoot :: Bool
+  , withConstantFolding    :: Bool
+  }
+
+class Simplify a where
+   simplifyWith :: SimplifyConfig -> a -> a
+   simplify :: a -> a
+   simplify = simplifyWith simplifyConfig
+
+simplifyConfig :: SimplifyConfig
+simplifyConfig = SimplifyConfig True True True True True
+
+instance Simplify a => Simplify (Context a) where
+   simplifyWith cfg = changeInContext $ simplifyWith cfg
+
+instance Simplify a => Simplify (Equation a) where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify a => Simplify (Relation a) where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify a => Simplify [a] where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify Expr where
+   simplifyWith cfg = let optional p f = if p then f else id in
+       optional (withSmartConstructors cfg)  (transform smart)
+     . optional (withMergeAlike cfg)         mergeAlike
+     . optional (withDistribution cfg)       distribution
+     . optional (withSimplifySquareRoot cfg) (View.simplify
+                                               (squareRootViewWith rationalView))
+     . optional (withConstantFolding cfg)    constantFolding
+
+instance Simplify a => Simplify (Rule a) where
+   simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards
+
+data Simplified a = S a deriving (Eq, Ord, Typeable)
+
+instance Show a => Show (Simplified a) where
+   show (S x) = show x
+
+instance (Read a, Simplify a) => Read (Simplified a) where
+   readsPrec n = map (mapFirst simplified) . readsPrec n
+
+instance (Num a, Simplify a) => Num (Simplified a) where
+   (+)         = liftS2 (+)
+   (*)         = liftS2 (*)
+   (-)         = liftS2 (-)
+   negate      = liftS negate
+   abs         = liftS abs
+   signum      = liftS signum
+   fromInteger = simplified . fromInteger
+
+instance (Fractional a, Simplify a) => Fractional (Simplified a) where
+   (/)          = liftS2 (/)
+   recip        = liftS recip
+   fromRational = simplified . fromRational
+
+instance (Floating a, Simplify a) => Floating (Simplified a) where
+   pi      = simplified pi
+   sqrt    = liftS  sqrt
+   (**)    = liftS2 (**)
+   logBase = liftS2 logBase
+   exp     = liftS exp
+   log     = liftS log
+   sin     = liftS sin
+   tan     = liftS tan
+   cos     = liftS cos
+   asin    = liftS asin
+   atan    = liftS atan
+   acos    = liftS acos
+   sinh    = liftS sinh
+   tanh    = liftS tanh
+   cosh    = liftS cosh
+   asinh   = liftS asinh
+   atanh   = liftS atanh
+   acosh   = liftS acosh
+
+instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where
+   toTerm (S x) = toTerm x
+   fromTerm     = fmap simplified . fromTerm
+
+instance (Reference a, Simplify a) => Reference (Simplified a)
+
+simplified :: Simplify a => a -> Simplified a
+simplified = S . simplify
+
+liftS :: Simplify a => (a -> a) -> Simplified a -> Simplified a
+liftS f (S x) = simplified (f x)
+
+liftS2 :: Simplify a => (a -> a -> a) -> Simplified a -> Simplified a -> Simplified a
+liftS2 f (S x) (S y) = simplified (f x y)
+
+simplifyRule :: Simplify a => Rule a
+simplifyRule = simplify (idRule "simplify")
+
+-------------------------------------------------------------
+-- Distribution of constants
+
+distribution :: Expr -> Expr
+distribution = descend distribution . f
+ where
+  f expr =
+   fromMaybe expr $
+   case expr of
+      a :*: b -> do
+         (x, y) <- match plusView a
+         r      <- match rationalView b
+         return $ (fromRational r .*. x) .+. (fromRational r .*. y)
+       `mplus` do
+         r      <- match rationalView a
+         (x, y) <- match plusView b
+         return $ (fromRational r .*. x) .+. (fromRational r .*. y)
+      a :/: b -> do
+         xs <- match sumView a
+         guard (length xs > 1)
+         return $ build sumView $ map (./. b) xs
+      _ -> Nothing
+
+-------------------------------------------------------------
+-- Constant folding
+
+-- Not an efficient implementation: could be improved if necessary
+constantFolding :: Expr -> Expr
+constantFolding expr =
+   case match rationalView expr of
+      Just r  -> fromRational r
+      Nothing -> descend constantFolding expr
+
+----------------------------------------------------------------------
+-- merge alike for sums and products
+
+-- Todo: combine with mergeAlike (subtle differences)
+collectLikeTerms :: Expr -> Expr
+collectLikeTerms = View.simplifyWith f sumView
+ where
+   f = mergeAlikeSum . map (View.simplifyWith (second mergeAlikeProduct) productView)
+
+mergeAlike :: Expr -> Expr
+mergeAlike a =
+   case (match sumView a, match productView a) of
+      (Just xs, _) | length xs > 1 ->
+         build sumView (sort $ mergeAlikeSum $ map mergeAlike xs)
+      (_, Just (b, ys)) | length (filter (/= 1) ys) > 1 ->
+         build productView (b, sort $ mergeAlikeProduct $ map mergeAlike ys)
+      _ -> a
+
+mergeAlikeProduct :: [Expr] -> [Expr]
+mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ]
+ where
+   f []                    = []
+   f ((Nothing  , e):xs)   = e:f xs
+   f ((Just r   , _):xs)   =
+      let cs   = r : [ c | (Just c, _) <- xs ]
+          rest = [ x | (Nothing, x) <- xs ]
+      in build rationalView (product cs):rest
+
+mergeAlikeSum :: [Expr] -> [Expr]
+mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ]
+ where
+   pm :: Rational -> Expr -> (Rational, Expr)
+   pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of
+                         (Just r1, _) -> pm (r*r1) e2
+                         (_, Just r1) -> pm (r*r1) e1
+                         _           -> (r, e1 .*. e2)
+   pm r (Negate e) = pm (negate r) e
+   pm r e = case match rationalView e of
+               Just r1 -> (r*r1, Nat 1)
+               Nothing -> (r, e)
+
+   rec [] = []
+   rec ((Nothing, e):ys) = e:rec ys
+   rec ((Just (r, a), e):ys) = new:rec rest
+    where
+      (js, rest) = partition (maybe False ((==a) . snd) . fst) ys
+      rs  = r:map fst (mapMaybe fst js)
+      new | null js   = e
+          | otherwise = build rationalView (sum rs) .*. a
+ src/Domain/Math/SquareRoot/Views.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Domain.Math.SquareRoot.Views
+   ( squareRootView, squareRootViewWith
+   ) where
+
+import Control.Monad
+import Domain.Math.Data.SquareRoot
+import Domain.Math.Expr hiding ((^))
+import Domain.Math.Numeric.Views
+import Domain.Math.Safe
+import Ideas.Common.View
+
+squareRootView :: View Expr (SquareRoot Expr)
+squareRootView = squareRootViewWith identity
+
+squareRootViewWith :: (Eq a,Fractional a) => View Expr a -> View Expr (SquareRoot a)
+squareRootViewWith v = makeView f g
+ where
+   f expr =
+      case expr of
+         Nat a    -> Just (fromIntegral a)
+         a :+: b  -> (+) <$> f a <*> f b
+         a :-: b  -> (-) <$> f a <*> f b
+         Negate a -> fmap negate (f a)
+         a :*: b  -> (*) <$> f a <*> f b
+         a :/: b  -> join $ safeDiv <$> f a <*> f b
+         Sqrt a   -> fmap sqrtRational (match rationalView a)
+         Sym s [a, b] | isPowerSymbol s ->
+            power <$> f a <*> match integerView b
+         _ -> fmap con (match v expr)
+
+   power a n
+      | n >= 0    = a ^ n
+      | otherwise = 1 / (a ^ abs n)
+
+   g = to sumView . map h . toList
+   h (a, n)
+      | n == 0    = 0
+      | n == 1    = build v a
+      | otherwise = build v a .*. Sqrt (fromIntegral n)
+ src/Main/Diagnose.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Main.Diagnose where++import Main.ParserCSV+import Data.List+import Data.Time+import Ideas.Common.Id+import Ideas.Text.HTML+import Recognize.Data.MathStoryProblem+import Recognize.Data.Approach+import Recognize.Data.Entry+import Recognize.Data.Solution+import Util.W3CSSHTML++diagnoseSingle :: MathStoryProblem -> String -> IO Entry+diagnoseSingle e _ = timed $ do+    let entry = diagnose e (defaultSolution [error "diagnoseSingle conversion of Solution"])+    print entry+    writePage ("single."++show e) (makePage (show e) (toHTML entry))+    return entry++diagnoseMultiple :: MathStoryProblem -> CSV -> IO ()+diagnoseMultiple e csv = timed $ do+    let answers = map (defaultSolution . map (uncurry Input . fmap ((:[]).Right))) (restrict csv) -- [[Id,String]]+        nrs     =  [1 :: Int ..]+        entries = zipWith (\_ -> diagnose e) nrs answers -- todo add ann and gs to entry+    -- writeFileMsg "output/extracted.txt" (outExtract entries) -- always empty+    writeFileMsg "output/diagnosed.txt" (outDiagnose entries)+    writeFileMsg "output/categories.txt" (outCategories entries)+    writeOutput ("output/out."++show e++".txt") entries+    writePage ("all."++show e) (makePage (show e) (mconcat (map toHTML entries)))+    --writePages ("html/all."++show e++".html") False entries+  --  writeErrors "output/errors.txt" entries+    putStrLn $ "Answers: " ++ show (length entries)+    putStrLn $ categoryStatistics entries++timed :: IO a -> IO a+timed m = do+    t0 <- getCurrentTime+    a  <- m+    t1 <- getCurrentTime+    putStrLn $ "time: " ++ show (diffUTCTime t1 t0)+    return a++writeOutput :: FilePath -> [Entry] -> IO ()+writeOutput file = writeFileMsg file . show++{-}+writeErrors :: FilePath -> [Entry e] -> IO ()+writeErrors file = writeFileMsg file . show . filter p . map f+  where+    f x = x { rawText = [], formulas = filter (isNothing . getExpr) (formulas x) }+    p = not . null . formulas+-}++writeFileMsg :: FilePath -> String -> IO ()+writeFileMsg file s = do+    putStr $ "Generating " ++ file ++ "... "+    writeFile file s+    putStrLn "ok"++-- outExtract :: [Entry e] -> String+-- outExtract = unlines . concatMap f+--   where+--     f entry+--       | null (Recognize.Data.Entry.formulas entry) = [nr ++ "EMPTY"]+--       | otherwise = map g (Recognize.Data.Entry.formulas entry)+--       where+--         nr  = "#" ++ show (entryNr entry) ++ ": "+--         g x = case getExpr x of+--                   Just xs -> nr ++ show xs+--                   Nothing -> nr ++ "ERROR: " ++ getString x++outDiagnose :: [Entry] -> String+outDiagnose = unlines . zipWith f [0 :: Int ..]+  where+    f nr entry = nrStr ++ "\n" ++ concatMap (\d -> show d ++ "\n") (diagnoses entry)+      where+        nrStr = "#" ++ show nr ++ ": "++outCategories :: [Entry] -> String+outCategories = unlines . zipWith f [0 :: Int ..]+  where+  f nr entry = nrStr ++ intercalate ", " (map (show . approach) $ diagnoses entry)+    where+    nrStr = "#" ++ show nr ++ ": "++categoryStatistics :: [Entry] -> String+categoryStatistics xs = unlines $ map f $ count $ map categoryAsString xs+  where+    nrTotal  = length xs+    f (d, n) = d ++ ": " ++ show n ++ percPar n nrTotal++count :: Ord a => [a] -> [(a, Int)]+count = map f . group . sort+  where+    f xs = (head xs, length xs)++percPar :: Integral a => a -> a -> String+percPar x y = " (" ++ perc x y ++ ")"++perc :: Integral a => a -> a -> String+perc x y | y == 0 = "0%"+         | otherwise = show d ++ "." ++ make (show m) ++ "%"+  where+    (d, m) = (round ((10000 * fromIntegral x / fromIntegral y) :: Double) :: Integer) `divMod` 100++    make s = replicate (2 - length s) '0' ++ s++    {-+instance Show Formula where+    show x = "  " ++ ljustify 25 (rawFormula x) ++ ": " +++      case recognized x of+          Just xs -> showChecked xs+          Nothing -> "???" ++ if balanced (rawFormula x) then "" else " (unbalanced)"+    where+      showChecked a = show a ++ if checkEquation a then "" else " (not equal)"++    showList = (++) . unlines . map show -}++restrict :: [[String]] -> [[(Id,String)]]+restrict xs = map (zip header) content+  where+    ys = map (map normalize) xs+    header = map newId (head ys)+    content = filter (\y -> p y && not (null y)) (tail ys)+    p = all (not . isInfixOf "v0")+{- = map normalize . filter (not . null) . drop 1 . map f+  where+    column x =+    f [_, x] = unlines $ filter (/= "v0") $ lines x+    f _ = error "invalid number of rows"+-}+normalize :: String -> String+normalize [] = []+normalize xs | "\\'" `isPrefixOf` xs = "'" ++ normalize (drop 2 xs)+              | "\\\"" `isPrefixOf` xs = '"' : normalize (drop 2 xs)+              | "&#x" `isPrefixOf` xs =+    case break (== ';') (drop 3 xs) of+      (xs1, ';':xs2) ->+          case lookup xs1 asciiTable of+            Just c  -> c : normalize xs2+            Nothing -> '?' : normalize xs2+      _ -> error "normalize"+normalize (x:xs) = x : normalize xs++asciiTable :: [(String, Char)]+asciiTable =+    [ ("e9", 'e') -- e acute+    , ("e0", 'a') -- a grave+    , ("e8", 'e') -- e grave+    , ("f9", 'u') -- u grave+    , ("ea", 'e') -- e circumflex+    , ("e2", 'a') -- a circumflex+    , ("e7", 'c') -- c cedilla+    , ("c3", 'A') -- A tilde+    , ("f7", '%') -- division+    , ("a0", ' ') -- space+    , ("a9", '?') -- copyright+    , ("b0", '?') -- ?????+    , ("aa", '?') -- ?????+    ]
+ src/Main/ParserCSV.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Main.ParserCSV (readFileCSV, CSV, Row, Cell) where
+
+import Control.Monad
+import Ideas.Utils.Parsing
+
+type CSV = [Row]
+type Row = [Cell]
+type Cell = String
+
+readFileCSV :: FilePath -> IO CSV
+readFileCSV = readFile >=> parseCSV
+
+parseCSV :: Monad m => String -> m CSV
+parseCSV = either fail return . parseSimple pCSV
+
+pCSV :: Parser CSV
+pCSV = many pRow
+
+pRow :: Parser Row
+pRow = pCell `sepBy` (char ';' <|> char ',') <* optionMaybe (char '\r') <* char '\n'
+
+pCell :: Parser Cell
+pCell = pQuotedCell
+    <|> many (noneOf ",;\r\n\"")
+
+pQuotedCell :: Parser Cell --v THIS PART WAS COMMENTED    v
+pQuotedCell = quoted (many (try (char '"' *> char '"') <|> noneOf "\""))
+
+quoted :: Parser a -> Parser a
+quoted = between (char '"') (char '"')
+ src/Main/Report.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Main.Report where
+
+import Control.Monad
+import Data.List
+import Data.Maybe (fromMaybe)
+import Data.Semigroup
+import Main.Tasks
+import Ideas.Common.Id
+import Ideas.Text.HTML
+import Ideas.Text.XML
+import Ideas.Text.HTML.W3CSS
+import Ideas.Encoding.Logging
+import Recognize.Data.MathStoryProblem
+import Recognize.Data.DiagnoseResult
+import Recognize.Data.Diagnosis
+import Recognize.Data.Entry
+import Recognize.Data.Solution
+import System.IO
+import Util.Cache
+import Util.Table
+
+import Control.Exception
+
+reportDatabase :: FilePath -> FilePath -> IO ()
+reportDatabase inFile outFile = do
+   hSetBuffering stdout NoBuffering
+   solutions <-
+      selectFrom inFile "requests" ["rowid","input"] $ \[rowid,txt] -> fallback (rowid, (defaultSolution [], newId "error")) . either error id $ do
+         xml <- parseXML txt
+         exid <- newId <$> findAttribute "exerciseid" xml
+         sol  <- findChild "solution" xml >>= fromXML
+         return (rowid, (sol, exid))
+   results <-
+      forM solutions $ \(nr, (sol, exid)) -> fallback (mempty, mempty) . either error id $ do
+         Task t <- findTask exid
+         let entry = diagnose t sol
+         let html  = header (string $ '#' : show nr) (string $ show exid)
+                     <> toHTML entry
+         return (html, countEntry exid entry)
+
+   let (outs, counts) = unzip results
+   writeFile outFile $ showHTML $ w3css $ htmlPage inFile $ mconcat outs
+   --writeCache "cache.txt"
+   putStrLn ""
+   print (percentage $ mconcat counts)
+
+
+-- | This is how we'll deal with errors for now: we just present a fallback
+-- value, mention the error, and continue.
+fallback :: a -> a -> IO a
+fallback def val = do
+   action <- try (evaluate val)
+   case action of
+      Left err -> do
+         putStrLn "Warning - something went wrong. Continuing with default value. The error was:"
+         print (err :: SomeException)
+         return def
+      Right result' -> return result'
+
+
+
+header :: BuildXML a => a -> a -> a
+header x y = container $ background DarkGray $
+   styleA "padding:0" <>
+   (Ideas.Text.XML.tag "div" . left . padding Medium) x <>
+   (Ideas.Text.XML.tag "div" . right . padding Medium) y
+
+countEntry :: Id -> Entry -> Tables Count
+countEntry n = mconcat . map (countResult n) . diagnoses
+
+countResult :: Id -> DiagnoseResult -> Tables Count
+countResult n r =
+   let i = getInputId (originalInput r)
+   in count (show i ++ "." ++ show n) . either (const "error") (show . category) . diagnosis $ r
+ src/Main/Tasks.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Main.Tasks +   ( tasks+   , findTask+   , findTaskFuzzy +   , fullNetwork+   , taskNetwork+   ) where++import Ideas.Common.Id+import Recognize.Data.MathStoryProblem+import Task.AreaAndExpression+import Task.AreaOfATriangle+import Task.CarRental+import Task.MagicTrick.Recognizer+import Task.MakingASquare+import Task.Matryoshka.Recognizer+import Task.Pattern.Recognizer+import Task.RectangleArea+import Task.TheatreRate.Recognizer+import Task.VPattern.Recognizer+import Data.List+import Util.String ( normalize )++import Bayes.Network ( Network )+import qualified Task.Network.StudentModel as StudentModel++-- | The list of Advise-me exercises+tasks :: [Task]+tasks =+   [ Task areaAndExpression+   , Task areaOfATriangle+   , Task carRental+   , Task makingASquare+   , Task matryoshka+   , Task pattern+   , Task rectangleArea+   --, Task rectangleAreaOld+   , Task theatreRate+   , Task vPattern+   , Task magicTrick+   ]++findTask :: Monad m => Id -> m Task+findTask i =+   case find (\t -> i == getId t) tasks of+      Just t  -> return t+      Nothing -> fail $ "Could not find task " ++ show i++-- | Find task, being forgiving about capitalisation, whitespace and+-- interpunction.+findTaskFuzzy :: Monad m => String -> m Task+findTaskFuzzy i =+   case find (\t -> normalize i == normalize (showId t)) tasks of+      Just t  -> return t+      Nothing -> fail $ "Could not find task " ++ show i+++-- | Combined network for all tasks.+fullNetwork :: Network ()+fullNetwork = mappend StudentModel.network taskNetwork++-- | Combined network for all tasks (without student model).+taskNetwork :: Network ()+taskNetwork = mconcat +            . map (\(Task t) -> singleNetwork t) +            $ tasks+
+ src/Recognize/Data/Approach.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Recognize.Data.Approach where
+
+import Control.Monad
+import Data.List
+import Ideas.Text.HTML
+import Ideas.Text.XML
+import Test.QuickCheck
+
+class HasApproach a where
+  approach :: a -> Approach
+
+-- | Approach = Category
+data Approach = Algebraic | Arithmetic | Numerical | Recursive | Generalizing | Graphical | Other String | NoApproach deriving (Eq, Ord)
+
+instance Show Approach where
+  show Algebraic    = "algebraic"
+  show Arithmetic   = "arithmetic"
+  show Numerical    = "numerical"
+  show Recursive    = "recursive"
+  show Generalizing = "generalizing"
+  show Graphical    = "graphical"
+  show (Other s)      = "Other: " ++ s
+  show NoApproach   = "noapproach"
+
+instance ToHTML Approach where
+   toHTML = text
+
+instance ToXML Approach where
+   toXML a = makeXML "approach" $ text a
+
+instance InXML Approach where
+   fromXML xml = do
+      unless (name xml == "approach") $ fail "expecting <approach> element"
+      case getData xml of
+         "algebraic"    -> return Algebraic
+         "arithmetic"   -> return Arithmetic
+         "numerical"    -> return Numerical
+         "recursive"    -> return Recursive
+         "generalizing" -> return Generalizing
+         "graphical"    -> return Graphical
+         "noapproach"   -> return NoApproach
+         txt | "Other: " `isPrefixOf` txt -> return (Other (drop 7 txt))
+             | otherwise -> fail $ "unknown approach " ++ txt
+
+instance Arbitrary Approach where
+  arbitrary = oneof (pure <$> [Algebraic,Arithmetic, Numerical, Recursive, Generalizing, Graphical, Other "", NoApproach])
+ src/Recognize/Data/Attribute.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the data type that is used to describe the diagnosis of some solution to an exercise.+-- This information is then used to generate evidence during assessment.+--+-----------------------------------------------------------------------------++module Recognize.Data.Attribute where++import Control.Arrow+import Data.List.NonEmpty+import Ideas.Common.Rewriting.Term+import Ideas.Text.XML hiding (Attribute)+import Domain.Math.Expr+import Domain.Math.Data.Relation+import Recognize.Data.Op+import Recognize.Data.RuleId++data Attribute =+    Expand Op -- ^ Expand a formula by a certain operation+  | Implicit Op -- ^ Implicitly expand a formula+  | Forget Op -- ^ Forgot to expand a formula+  | ForgetSym Symbol -- ^ Forgot to expand with a symbol+  | Normalized -- ^ Is a normalized expression+  | InvalidEquation -- 5 == 6+    Expr -- Left+    Expr -- Right+  | UnequalRelations -- 3x=40 | x = 40/2+    (Relation Expr) -- before relation+    (Relation Expr) -- after relation+  | Recovery -- ^ Recover a made mistake+  | NonMatchingParentheses -- ^ Incorrect placement of parentheses+  | IncorrectDistribution+  | IncorrectFactorization+  | InvertedFraction -- ^ expected: 5/6, provided: 6/5+  | InvalidCommutativity Symbol -- ^ expected: 5-6, provided: 6-5+  | AtomMixedUp  -- expected: 5 + 6, provided: 8 + 8+      Expr -- wrong+      Expr -- correct+  | Sloppiness+  | OperatorMixedUp -- expected: 5-6, provided: 5+6+     Symbol -- wrong+     Symbol -- correct+  | Misconception+     Concept -- wrong+     Concept -- correct+  | AsymmetricRelation+  | InequalityStrictness+  | Approximation+  | RoundingError+  | CommonMistake -- ^ defined per exercise+  | CapturedWildcard String Expr+  | PartialMatch Expr+  | MatchedBy Expr Expr+  | ARule -- Applied an ideas rule to some expression+      RuleId -- Matches an ideas rule+      (NonEmpty Expr) -- list expressions that rule is applied to+      Expr -- resulting expression+  | ARuleR -- Applied an ideas rule to some relation+      RuleId -- Matches an ideas rule+      (Relation Expr) -- relation that rule is applied to+      (Relation Expr) -- resulting relation+  | Label String+  | LabelE String Expr+  | FinalAnswer Expr+  | NExpr Expr -- ^ Expression that is a Number or Natural+  | Other String+ deriving (Eq, Show,Ord)++instance ToXML Attribute where+ toXML e = case e of+     Expand o                -> makeXML "expand" (text o)+     Implicit o              -> makeXML "implicit" (text o)+     Forget o                -> makeXML "forget" (text o)+     ForgetSym o             -> makeXML "forgetsym" (text o)+     InvalidCommutativity o  -> makeXML "invalidcommutativity" (text o)+     Normalized              -> makeXML "normalized" mempty+     (InvalidEquation e1 e2) -> makeXML "invalidequation" $ mconcat [element "left" [text e1], element "right" [text e2]]+     Recovery                -> makeXML "recovery" mempty+     NonMatchingParentheses  -> makeXML "nonmatchingparentheses" mempty+     IncorrectDistribution   -> makeXML "incorrectdistribution" mempty+     IncorrectFactorization  -> makeXML "incorrectfactorization" mempty+     InvertedFraction        -> makeXML "invertedfraction" mempty+     CapturedWildcard s e    -> makeXML "capturedwildcard" $ mconcat [element "wildcard" [text s],element "expr" [text e]]+     AtomMixedUp e1 e2       -> makeXML "atommixedup" $ mconcat [element "left" [text e1], element "right" [text e2]]+     Sloppiness              -> makeXML "sloppiness" mempty+     OperatorMixedUp w c     -> makeXML "operatormixedup" $ mconcat [element "wrong" [text w], element "correct" [text c]]+     Misconception w c       -> makeXML "misconception" $ mconcat [element "wrong" [text w], element "correct" [text c]]+     AsymmetricRelation      -> makeXML "asymmetricrelation" mempty+     InequalityStrictness    -> makeXML "inequalitystrictness" mempty+     RoundingError           -> makeXML "roundingerror" mempty+     CommonMistake           -> makeXML "commonmistake" mempty+     Approximation           -> makeXML "approximation" mempty+     Other s                 -> makeXML "other" (string s)++isMistake :: Attribute -> Bool+isMistake (InvalidEquation _ _)  = True+isMistake NonMatchingParentheses = True+isMistake (InvalidCommutativity _) = True+isMistake (ForgetSym _)          = True+isMistake IncorrectDistribution  = True+isMistake IncorrectFactorization = True+isMistake InvertedFraction       = True+isMistake (AtomMixedUp _ _)      = True+isMistake Sloppiness             = True+isMistake (OperatorMixedUp _ _)  = True+isMistake (Misconception _ _)    = True+isMistake AsymmetricRelation     = True+isMistake InequalityStrictness   = True+isMistake RoundingError          = True+isMistake CommonMistake          = True+isMistake _ = False++isApproximation :: Attribute -> Bool+isApproximation Approximation = True+isApproximation _ = False++isLabelAttr :: Attribute -> Bool+isLabelAttr (Label _) = True+isLabelAttr (LabelE _ _) = True+isLabelAttr _ = False++isCommonMistake :: Attribute -> Bool+isCommonMistake CommonMistake = True+isCommonMistake _ = False++data Concept = Area | Perimeter | Square | Triangle | Volume | Rectangle | HalfPerimeter+ deriving (Eq, Show, Ord)++infixl 7 <!++(<!) :: [(a, [Attribute])] -> Attribute -> [(a, [Attribute])]+xs <! a = second (a:) <$> xs
+ src/Recognize/Data/Definition.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.Definition where++import Domain.Math.Data.Relation+import Ideas.Common.Rewriting+import Ideas.Common.View++type Definition a = (String, a)++definitionView :: WithVars a => View (Relation a) (Definition a)+definitionView = makeView toDefinition fromDefinition++toDefinition :: WithVars a => Relation a -> Maybe (Definition a)+toDefinition r | relationType r == EqualTo+               , Just v <- getVariable (leftHandSide r) = Just (v, rightHandSide r)+               | relationType r == EqualTo+               , Just v <- getVariable (rightHandSide r) = Just (v, leftHandSide r)+              | otherwise = Nothing++fromDefinition :: WithVars a => Definition a -> Relation a+fromDefinition (s,e) = variable s .==. e
+ src/Recognize/Data/DiagnoseError.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.DiagnoseError where++import Ideas.Text.XML hiding (tag)+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS++data DiagnoseError = Empty | Timeout | Unknown+ deriving (Show, Eq)++instance ToXML DiagnoseError where+ toXML Empty = makeXML "empty" mempty+ toXML Timeout = makeXML "timeout" mempty+ toXML Unknown = makeXML "unknown" mempty++instance ToHTML DiagnoseError where+   toHTML = tag . background Red . string . ("DiagnoseError: " ++) .  show
+ src/Recognize/Data/DiagnoseResult.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.DiagnoseResult where++import Recognize.Data.Solution+import Recognize.Data.DiagnoseError+import Recognize.Data.Approach+import Recognize.Data.Diagnosis hiding (result)+import Bayes.Evidence+import Recognize.Data.StringLexer+import Recognize.Data.MathParserOutput+import Data.Semigroup+import Util.String+import Ideas.Text.XML+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS hiding (tag)+import qualified Text.PrettyPrint.Leijen as PP++data DiagnoseResult = DiagnoseResult+   { originalInput :: Input+   , lexerOutput   :: LexerOutput+   , parserOutput  :: MathParserOutput+   , diagnosis     :: Either DiagnoseError Diagnosis+   , evidence      :: Evidence+   }++instance Show DiagnoseResult where+   show = show . PP.pretty++instance PP.Pretty DiagnoseResult where+   pretty result = PP.vcat+      [ PP.string "Original input"+      , PP.indent 2 (PP.vcat $ map f (getInput (originalInput result)))+      , pp "Lexer output"   $ PP.pretty (lexerOutput result)+      , pp "Parser output"  $ PP.pretty (parserOutput result)+      , pp "Diagnosis"      $ either (PP.string . show) PP.pretty (diagnosis result)+      , pp "Evidence"       $ PP.string $ show (evidence result)+      ]+    where+      pp s a = PP.string (s ++ ":") PP.<$$> PP.indent 2 a+      f = PP.string . either show id++instance HasApproach DiagnoseResult where+  approach = either (Other . strToLower . show) approach . diagnosis++instance ToHTML DiagnoseResult where+   listToHTML = mconcat . map toHTML+   toHTML res = rowsHalf+      ( f inputStr    $ toHTML (originalInput res)+      , f "lexer" $ tag "id" (string "temporarily disabled due to 'invalid name table' error")+      , f "parser" $ w3panel $ tag "id" (string "temporarily disabled due to 'invalid name table' error")+      --, f "lexer"     $ toHTML (lexerOutput res)+      --, f "parser"    $ w3panel $ toHTML (parserOutput res)+      , f "diagnosis" $ toHTML (diagnosis res)+      , f "evidence"  $ w3panel $+           if isEmpty (evidence res) then string "(no evidence)"+           else text (evidence res)+      )+      {-+      )-}+    where+      inputStr = "input " ++ show (getInputId (originalInput res))+      f s body = w3right s <> body++w3panel :: HTMLBuilder -> HTMLBuilder+w3panel xs = panel xs++rowsHalf :: BuildXML a => (a, a, a, a, a) -> a+rowsHalf (x1, x3, x4, x5, x6) = container $+   tag "div" $ rowPadding $ tag "div" (classA "w3-col m6 l7" <> mconcat+   [br, f x1, br, f x3, br, f x5, br]) <>+      tag "div" (classA "w3-col m6 l5" <> mconcat+   [br, f x4, br, f x6, br])+ where+   f x = tag "div" $ card $ background White $ rounded Medium $+            container x++w3right :: String -> HTMLBuilder+w3right s = tag "div" $ bar $ tag "div" $ right $ background LightGray $ small $+   space <> string s <> space++instance ToXML DiagnoseResult where+   toXML result = makeXML "diagnoseresult" $ mconcat+      [ element "originalinput" [builderXML $ originalInput result]+      , element "lexeroutput" [builderXML $ lexerOutput result]+      , element "parseroutput" [builderXML $ parserOutput result]+      , element "diagnosis" [builderXML $ diagnosis result]+      ]
+ src/Recognize/Data/Diagnosis.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.Diagnosis+   ( Diagnosis(..), Step+   , newDiagnosis, hasMistakes+   , getMath, getMaths, addAttribute, mergeSteps+   , makeFAStep, getAttributes+   ) where++import Data.List+import Data.Semigroup+import Domain.Math.Expr+import Ideas.Common.Id+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS+import Ideas.Text.XML hiding (Attribute)+import Recognize.Data.Attribute+import Recognize.Data.Approach+import Recognize.Data.Math+import Recognize.Data.Step+import Util.W3CSSHTML+import qualified Text.PrettyPrint.Leijen as PP++data Diagnosis = Diagnosis+  { category            :: Approach+  , correctResult       :: Bool+  , resultIsSimplified  :: Bool+  , parenthesisMismatch :: Bool+  , payload             :: Maybe Expr -- exercise specific data (only used for MagicExpression in MagicTrick)+  , steps               :: [Step]+  , result              :: Maybe Expr+  }+ deriving Eq++instance Show Diagnosis where+   show = show . PP.pretty++instance PP.Pretty Diagnosis where+   pretty d = PP.vcat+      [ pp "Category"   $ PP.string (show (category d))+      , pp "Payload"    $ PP.string (show (payload d))+      , PP.string "Steps:"+      , PP.vcat $ map (PP.indent 2 . PP.string . show) (steps d)+      , pp "Result"     $ PP.string (show (result d))+      , pp "Properties" $ PP.string (intercalate ", " xs)+      ]+    where+      xs = [ s | (s, f, _) <- propList, f d ]+      pp s a = PP.string (s ++ ": ") PP.<> a++instance HasApproach Diagnosis where+   approach = category++propList :: [(String, Diagnosis -> Bool, Color)]+propList =+   [ ("correct result", correctResult, Green)+   , ("result is simplified", resultIsSimplified, Green)+   , ("parenthesis mismatch", parenthesisMismatch, Red)+   ]++newDiagnosis :: Approach -> [Step] -> Diagnosis+newDiagnosis app st = Diagnosis+  { category = app+  , correctResult = False+  , resultIsSimplified = False+  , parenthesisMismatch = any (elem NonMatchingParentheses) attrs+  , payload = Nothing+  , steps = st+  , result = Nothing+  }+  where attrs = map getAttributes st++instance ToXML Diagnosis where+ toXML d = makeXML "standarddiagnosis" $ mconcat+  [ element "category" [string (show $ category d)]+  , element "correctResult"       [string (show $ correctResult       d)]+  , element "resultIsSimplified"  [string (show $ resultIsSimplified  d)]+  , element "parenthesisMismatch" [string (show $ parenthesisMismatch d)]+  , element "payload" [builderXML $ payload d]+  , element "steps" (map builderXML $ steps d)+  , element "result" [builderXML $ result d]+  ]++instance ToHTML Diagnosis where+   toHTML d = mconcat+      [ toHTML (steps d)+      , maybe mempty (para . string . ("result: " ++) . show) (result d)+      , let body = toHTML (payload d)+        in h3 "payload" <> body+      , htmlProps $ (show (category d), const True, Yellow) : propList+      ]+    where+      htmlProps = para . w3tags . concatMap f+       where+         f (s, p, c) = [ (s, c) | p d ]
+ src/Recognize/Data/Entry.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- An entry is created for each request that is diagnosed. It contains the diagnosis result for each made input.+-- At some later point it will also be filled with the assessment of the diagnosis.+--+-----------------------------------------------------------------------------++module Recognize.Data.Entry where++import Data.List+import Ideas.Common.Id+import Recognize.Data.DiagnoseError+import Recognize.Data.Approach+import Recognize.Data.Solution+import Recognize.Data.DiagnoseResult+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS+import Ideas.Text.XML+import qualified Text.PrettyPrint.Leijen as PP++data Entry = Entry+   {+      diagnoses   :: [DiagnoseResult] -- ^ diagnose result for each input of the exercise+   }++instance Show Entry where+ show = show . PP.pretty++instance PP.Pretty Entry where+   pretty e = PP.vcat+      [ PP.string ("=== Diagnosis " ++ show i ++ " ===")+        PP.<$$> PP.indent 2 (PP.pretty d)+      | d <- diagnoses e+      , let i = getInputId (originalInput d)+      ]+    where+      pp s = maybe PP.empty (\x -> PP.string $ s ++ ": " ++ show x)++instance ToXML Entry where+ toXML e = makeXML "entry" $ mconcat+     [ element "diagnoses"+         (map+          (\v-> let k = getInputId (originalInput v)+                in element "input" ["id" .=. show k, builderXML v])+         (diagnoses e)+         )+     ]+++instance ToHTML Entry where+   toHTML e = container $ background LightGray $ mconcat+      [ if null (diagnoses e)+        then string "(no diagnoses)"+        else toHTML (diagnoses e)+      ]++-- | Determine the category of the overal solution and then show it+categoryAsString :: Entry -> String+categoryAsString e+   | null (diagnoses e) = show Unknown+   | otherwise = intercalate ", " (map (show . approach) (diagnoses e))
+ src/Recognize/Data/Math.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Defines the `Math` type and closely associated functions.+--+-----------------------------------------------------------------------------++module Recognize.Data.Math where++import Control.Monad+import Data.Char+import Data.Either+import Data.List+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Ideas.Common.Rewriting+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS+import Ideas.Text.OpenMath.Dictionary.Relation1+import Ideas.Text.XML+import Test.QuickCheck+import Util.Parentheses+import Util.W3CSSHTML+import Util.XML++-- ppExpr was moved from Util module+ppExpr :: Expr -> String+ppExpr (Sym s [x, y]) | s == newSymbol eqSymbol =+ show x ++ " = " ++ show y+ppExpr (Sym s xs) | s == chainedEqSymbol = intercalate " = " (map show xs)+ppExpr e = show e++isFunctionDefinition :: Expr -> Bool+isFunctionDefinition (Sym s [Var _]) | isFunctionCallSymbol s = True+isFunctionDefinition _ = False++isDefinition :: Expr -> Bool+isDefinition = (||) <$> isVariable <*> isFunctionDefinition+----------++data Math = M+   { getString :: String -- ^ original parsed string+   , getResult :: Either MathParseError Expr -- ^ Either a parse error or a successfully parsed expression+   } deriving (Eq)+++newtype MathParseError = MathParseError { asString :: String }+ deriving (Eq)++instance Show MathParseError where+  show (MathParseError e) = e++instance Arbitrary MathParseError where+  arbitrary = MathParseError <$> arbitraryPrintable++instance ToXML MathParseError where+   toXML s = makeXML "MathParseError" (string (asString s))++instance InXML MathParseError where+ fromXML e = case name e of+   "MathParseError" -> pure $ MathParseError (unescape (getData e))+   _ -> fail "Util.Either:InXML.String"+++instance ToXML Math where+   toXML m = makeXML "math" $ mconcat [ "getString" .=. getString m+                                     , builderXML (getResult m)]++instance InXML Math where+  fromXML xml = do +     unless (name xml == "math") $ fail "expecting <math> element"+     s   <- findAttribute "getString" xml+     res <- case children xml of+               [a] -> fromXML a+               _   -> fail "invalid <math> element"+     return $ M (unescapeAttr s) res++instance Arbitrary Math where+  arbitrary = M <$> arbitraryPrintable <*> arbitrary++instance ToHTML Math where+   listToHTML = w3list . map toHTML+   toHTML a =+      case getExpr a of+         Just xs -> string (ppExpr xs)+         Nothing -> background Red (string (getString a))++arbitraryPrintable :: Gen String+arbitraryPrintable = listOf (arbitrary `suchThat` isPrint)++mathListHtml :: [Math] -> HTMLBuilder+mathListHtml [] = mempty+mathListHtml xs = (tableAll . w3class "w3-small" . mconcat . make . map toHTML) xs+ where+  make = map (\x -> tr [td x])+++isParseError :: Math -> Bool+isParseError = isLeft . getResult+++printMath :: Math -> String+printMath (M s r) = "M { " ++ s ++ ", " ++ show r ++ " }"++instance Show Math where+   show x =+      case getResult x of+         Left _ ->+            let msg = if balanced (getString x) then "" else " (unbalanced)"+            in "ERROR: " ++ getString x ++ msg+         Right e -> show e++makeMath :: Expr -> Math+makeMath e = M (show e) (Right e)++showMathList :: [Math] -> String+showMathList xs = unlines (zipWith f as bs)+  where+    as = map getString xs+    bs = map show xs+    n  = maximum (map length as)+    f x y = ">>  " ++ ljustify n x ++ "   : " ++ y+    ljustify n s = take (n `max` length s) (s ++ repeat ' ')++-- | Returns the parsed expression or fails+getExpr :: Monad m => Math -> m Expr+getExpr = either (fail . asString) return . getResult++-- | Returns the parsed relation or fails+getRelation :: Monad m => Math -> m (Relation Expr)+getRelation = getExpr >=> getRelationE++-- | Returns the parsed relation or fails+getRelationE :: Monad m => Expr -> m (Relation Expr)+getRelationE = isRelation+  where+    isRelation (Sym s [x, y]) | Just (rel,(_,_)) <- find ((==s).snd.snd) relationSymbols+                            = return $ makeType rel x y+    isRelation _ = fail "not an equation"++getEq :: Monad m => Math -> m (Equation Expr)+getEq = getExpr >=> getEqE++getEqE :: Monad m => Expr -> m (Equation Expr)+getEqE (Sym s [x, y]) | s == newSymbol eqSymbol = return (x :==: y)+getEqE _ = fail "not an equation"++getChainedEq :: Monad m => Math -> m [Expr]+getChainedEq = getExpr >=> isChained+  where+    isChained (Sym s xs) | s == chainedEqSymbol = return xs+    isChained _ = fail "not a chained equation"++isEq :: Expr -> Bool+isEq (Sym s [_,_]) = s == newSymbol eqSymbol+isEq _ = False++-- Some Math symbols+chainedEqSymbol :: Symbol+chainedEqSymbol = newSymbol "chained-eq"++functionCallSymbol :: Symbol+functionCallSymbol = newSymbol "function-call"++isChainedEqSymbol :: Symbol -> Bool+isChainedEqSymbol = (== chainedEqSymbol)++isChainedEq :: Expr -> Bool+isChainedEq (Sym s _) = isChainedEqSymbol s++isFunctionCallSymbol :: Symbol -> Bool+isFunctionCallSymbol = (== functionCallSymbol)++isFunctionCall :: Expr -> Bool+isFunctionCall (Sym s _) = isFunctionCallSymbol s+isFunctionCall _ = False
+ src/Recognize/Data/MathParserOptions.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.MathParserOptions +   ( MathParserOptions, mathParserOptions+   , multByConcatenation, convertToLowercase, functionCallWhitelist+   ) where++import Data.Semigroup++-- | Parameters for "Recognize.Parsing.MathParser"+data MathParserOptions = Opts+   { multByConcatenation   :: Bool -- ^ interpret ab as a*b+   , convertToLowercase    :: Bool -- ^ interpret A5 as a5+   , functionCallWhitelist :: [Char] -- ^ By default we only recognize f,g and h for function calls.+   }++mathParserOptions :: MathParserOptions+mathParserOptions = Opts+   { multByConcatenation   = True+   , convertToLowercase    = False+   , functionCallWhitelist = []+   }++instance Semigroup MathParserOptions where+   x <> y = Opts+      { multByConcatenation   = multByConcatenation x && multByConcatenation y+      , convertToLowercase    = convertToLowercase  x || convertToLowercase y+      , functionCallWhitelist = functionCallWhitelist x ++ functionCallWhitelist y+      }++instance Monoid MathParserOptions where+   mempty  = mathParserOptions+   mappend = (<>)
+ src/Recognize/Data/MathParserOutput.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.MathParserOutput where++import Data.Monoid ( (<>) )+import Ideas.Text.HTML                         hiding (table, ul)+import Ideas.Text.HTML.W3CSS                   hiding (input)+import Ideas.Text.XML                          hiding (tag)+import Recognize.Data.Math+import Recognize.Data.MathParserOptions+import Recognize.Parsing.MathParser+import Util.Monad+import qualified Text.PrettyPrint.Leijen as PP++data MathParserOutput = MathParserOutput { mathParserOutput :: [Math], hasChainedEquations :: Bool}+ deriving Eq++instance Show MathParserOutput where+   show = show . PP.pretty++instance PP.Pretty MathParserOutput where+   pretty a = PP.vcat $+      map (PP.string . show) (mathParserOutput a) +++      [ PP.string $ "Chained equations: " ++ show (hasChainedEquations a) ]++instance ToHTML MathParserOutput where+   toHTML m =+      toHTML (mathParserOutput m)+          <> mWhen (hasChainedEquations m) ((tag . background Orange . string) "chained")++instance ToXML MathParserOutput where+ toXML mpo = makeXML "mathparseroutput" $ mconcat+    [ element "mathparseroutput" (map builderXML (mathParserOutput mpo))+    , element "hasChainedEquations" [string (show (hasChainedEquations mpo))]+    ]++mathParser :: MathParserOptions -> [String] -> MathParserOutput+mathParser opts ss = MathParserOutput+               { mathParserOutput = fs+               , hasChainedEquations = or chainedEqs+               }+ where+  (chainedEqs,eqs) = unzip (map (parseMath opts) ss)+  fs = concat eqs
+ src/Recognize/Data/MathStoryProblem.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE ExistentialQuantification #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.MathStoryProblem+   ( Task(..)+   , MathStoryProblem, mathStoryProblem+   , problemId, processInputs+   , inputFile, networkFile, singleNetwork+   , getExercise, diagnose, analyzers+   , Analyzer, analyzer+   , lexer, parser, recognizer, collector+   ) where++import Data.Maybe+import Ideas.Common.Library hiding (recognizer, recognize, parser)+import Ideas.Text.HTML+import Ideas.Text.XML+import Bayes.Evidence+import Bayes.Network ( Network )+import Recognize.Data.DiagnoseResult+import Recognize.Data.Entry+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Data.DiagnoseError+import Recognize.Data.Solution+import Recognize.Data.Approach ( Approach(Other) )++getExercise :: MathStoryProblem -> Exercise b+getExercise e = emptyExercise { exerciseId = getId e }++data Task = Task (MathStoryProblem)++instance Show Task where+  show = showId++instance HasId Task where+   getId (Task pr) = getId pr+   changeId f (Task pr) = Task (changeId f pr)++findAnalyzer :: MathStoryProblem -> InputId -> Analyzer+findAnalyzer pr i = fromMaybe analyzer (lookup i (analyzers pr))++data MathStoryProblem = MSP+   { problemId     :: Id+   , processInputs :: [Input] -> [Input]+   , analyzers     :: [(InputId, Analyzer)]+   , inputFile     :: Maybe FilePath+   , networkFile   :: Maybe FilePath+   , singleNetwork :: Network ()+   }++data Analyzer = A+   { lexer      :: Maybe Language -> Input -> LexerOutput+   , parser     :: LexerOutput -> MathParserOutput+   , recognizer :: MathParserOutput -> Either DiagnoseError Diagnosis+   , collector  :: Diagnosis -> Evidence+   }++instance Show MathStoryProblem where+   show = show . problemId++instance HasId MathStoryProblem where+   getId = problemId+   changeId f pr = pr { problemId = f (problemId pr) }++mathStoryProblem :: MathStoryProblem+mathStoryProblem = MSP+   { problemId     = mempty+   , processInputs = id+   , analyzers     = []+   , inputFile     = Nothing+   , networkFile   = Nothing+   , singleNetwork = mempty+   }++analyzer :: Analyzer+analyzer = A+   { lexer      = stringLexer mempty+   , parser     = mathParser mempty . stringLexerOutput+   , recognizer = \_ -> Left Unknown+   , collector  = const mempty+   }++-----------------------------------------------------------------------------++diagnose :: MathStoryProblem -> Solution -> Entry+diagnose e sol = Entry (map f inps)+ where+   inps = processInputs e (inputs sol)+   f    = diagnoseInput e (language sol)++-- | @diagnosePipeline inputId e o i@ specifies how the input from some exercise is handled.+-- The input is lexed, parsed and then recognized. Any information from earlier phases is propagated to later phases.+diagnoseInput :: MathStoryProblem -> Maybe Language -> Input -> DiagnoseResult+diagnoseInput pr lang i = DiagnoseResult+   { originalInput = i+   , lexerOutput   = lex_out+   , parserOutput  = parse_out+   , diagnosis     = diag_out+   , evidence      = col_out+   }+ where+   ana       = findAnalyzer pr (getInputId i)+   lex_out   = lexer ana lang i+   parse_out = parser ana lex_out+   diag_out  = recognizer ana parse_out+   col_out   = either (const . collector ana $ newDiagnosis (Other "dummy diagnosis") []) (collector ana) diag_out
+ src/Recognize/Data/Op.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Recognize.Data.Op where
+
+import Control.Monad
+import Domain.Math.Expr
+import Ideas.Text.XML
+import Ideas.Utils.Prelude (readM)
+import Ideas.Utils.Uniplate
+import Test.QuickCheck
+import Util.XML
+
+-- | Describe how to expand a formula
+data Op = Add Expr | Sub Expr | Mul Expr | Div Expr
+ deriving (Eq, Ord)
+
+instance Show Op where
+   show (Add e) = "+" ++ show e
+   show (Sub e) = "-" ++ show e
+   show (Mul e) = "*" ++ show e
+   show (Div e) = "/" ++ show e
+
+instance Read Op where
+  readsPrec _ ('+':xs) = [(Add (read xs :: Expr), "")]
+  readsPrec _ ('-':xs) = [(Sub (read xs :: Expr), "")]
+  readsPrec _ ('*':xs) = [(Mul (read xs :: Expr), "")]
+  readsPrec _ ('/':xs) = [(Div (read xs :: Expr), "")]
+  readsPrec _ _ = []
+
+instance Arbitrary Op where
+  arbitrary = oneof
+               [ Add <$> arbitrary
+               , Mul <$> arbitrary
+               , Div <$> arbitrary
+               , Sub <$> arbitrary
+               ]
+
+instance ToXML Op where
+   toXML e = makeXML "op" (text e)
+
+instance InXML Op where
+  fromXML xml = do
+     unless (name xml == "op") $ fail "expecting <op> element"
+     readM (getData xml)
+
+-- | Apply an `Op` to and `Expr`
+fromOp :: Op -> Expr -> Expr
+fromOp (Add v) a = a + v
+fromOp (Sub v) a = a - v
+fromOp (Mul v) a = a * v
+fromOp (Div v) a = a / v
+
+-- | @fromOp' op e@ applies operator @op@ in the most bottom-right term (when op = div/mul) of @e@.
+-- eg: @fromOp' (/3) (4 + 2) = (4 + 2/3)@
+fromOp' :: Op -> Expr -> Expr
+fromOp' op@(Mul _) a = nestRight op a
+fromOp' op@(Div _) a = nestRight op a
+fromOp' op a = fromOp op a
+
+nestRight :: Op -> Expr -> Expr
+nestRight op (e1 :+: e2) = e1 :+: nestRight op e2
+nestRight op (e1 :*: e2) = e1 :*: nestRight op e2
+nestRight op (e1 :-: e2) = e1 :-: nestRight op e2
+nestRight op (e1 :/: e2) = e1 :/: nestRight op e2
+nestRight op a = fromOp op a
+
+fromOps :: [Op] -> Expr -> Expr
+fromOps = flip (foldl (flip fromOp))
+
+substOp :: Expr -> Op -> Op
+substOp a (Add v) = Add (substitute a v)
+substOp a (Sub v) = Sub (substitute a v)
+substOp a (Mul v) = Mul (substitute a v)
+substOp a (Div v) = Div (substitute a v)
+
+substitute :: Expr -> Expr -> Expr
+substitute a = rec
+ where
+   rec (Var "x") = toExpr a
+   rec expr      = descend rec expr
+
+formExpr :: Expr -> Expr -> [Op] -> Expr
+formExpr x a ops = fromOps (map (substOp x) ops) a
+ src/Recognize/Data/RuleId.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This is an important module that "Recognize.Strategy.Derivation" relies on.+-- Here we define the translation from Ideas rule identifiers to our own `RuleId` type.+-- If you want to add new rules in "Recognize.Strategy.Derivation" make sure to also add+-- a new translation here.+--+-----------------------------------------------------------------------------++module Recognize.Data.RuleId where++data RuleId = Collect_Num+  | Collect_Var+  | Times+  | Power+  | Division+  | Distr_Times+  | Distr_Division+  | Coverup_OneVar_Plus+  | Coverup_Times_Positive+  deriving (Eq, Ord)++instance Show RuleId where+  show Collect_Num            = "Collect"+  show Collect_Var            = "Collect"+  show Times                  = "Times"+  show Power                  = "Power"+  show Division               = "Divide"+  show Coverup_OneVar_Plus    = "Coverup.OneVar.Plus"+  show Coverup_Times_Positive = "Coverup.OneVar.Times-Positive"+  show Distr_Times            = "Distribute"+  show Distr_Division         = "Distribute"+  show _ = "Recognize.Data.RuleId: Show not implemented"++matchRuleId :: String -> Maybe RuleId+matchRuleId "algebra.equations.linear.distr-times"     = Just Distr_Times+matchRuleId "linear.merge.num"                         = Just Collect_Num+matchRuleId "linear.merge.var"                         = Just Collect_Var+matchRuleId "algebra.equations.rational.cancel-div"    = Just Division+matchRuleId "algebra.equations.coverup.onevar.plus"    = Just Coverup_OneVar_Plus+matchRuleId "algebra.equations.coverup.times-positive" = Just Coverup_Times_Positive+matchRuleId "algebra.manipulation.simpler-fraction"    = Just Division+matchRuleId "arithmetic.operation.rational.times"      = Just Times+matchRuleId "arithmetic.operation.rational.power"      = Just Power+matchRuleId "distr-division"                           = Just Distr_Division+matchRuleId _ = Nothing
+ src/Recognize/Data/Solution.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.Solution+   ( Solution(..), UserId, GroupId+   , Language(..), Source+   , Input(..), InputId, inputToString, defaultSolution+   ) where++import Control.Monad ( (>=>) )+import Data.Semigroup+import Ideas.Common.Library hiding (recognize, right)+import Ideas.Text.MathML+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS hiding (content, tag)+import Ideas.Text.XML++-- | An incoming request is parsed to a solution+data Solution = Solution+   { userId   :: UserId+   , groupId  :: GroupId+   , language :: Maybe Language+   , inputs   :: [Input]+   }+ deriving Show++instance ToXML Solution where+   toXML sol = makeXML "solution" $ mconcat $+      maybe mempty ("userid" .=.) (userId sol) :+      maybe mempty ("groupid" .=.) (groupId sol) :+      maybe mempty ("language" .=.) (show <$> language sol) :+      map builderXML (inputs sol)++instance InXML Solution where+   fromXML xml = do+      let uid = findAttribute "userid"   xml+          gid = findAttribute "groupid"  xml+          lan = findAttribute "language" xml >>= readM+      xs <- mapM fromXML (findChildren "input" xml)+      return (Solution uid gid lan xs)++type Source  = Maybe String+type UserId  = Maybe String+type GroupId = Maybe String++data Language = EN | FR | DE | NL+ deriving (Show, Read)++type InputId = Id++data Input = Input { getInputId :: InputId, getInput :: [Either MathML String] }+ deriving Show++-- | Since the current mixed content representation cannot support two+-- consecutive strings, we make sure that it does not contain two consecutive+-- @Right@ values.+collapseRights :: (b -> b -> b) -> [Either a b] -> [Either a b]+collapseRights combine (Right x:Right y:xs) = Right (combine x y) : collapseRights combine xs+collapseRights combine (x:xs) = x : collapseRights combine xs+collapseRights _       [] = []++--collapseLefts :: (a -> a -> a) -> [Either a b] -> [Either a b]+--collapseLefts f = let swap = either Right Left in swap . collapseRights f . swap++-- Reconsider xml representation for Input: the current mixed content representation cannot+-- support two consecutive String parts+instance ToXML Input where+ toXML inp = makeXML "input" $+    "id".=. show (getInputId inp) <> mconcat (map f (collapseRights (++) $ getInput inp))+  where+   f :: Either MathML String -> XMLBuilder+   f = either (builder . toXML) string++instance InXML Input where+   fromXML xml =+      Input <$> (newId <$> findAttribute "id" xml) <*> mapM f (content xml)+    where+      f :: Monad m => Either String XML -> m (Either MathML String)+      f = either (return . Right) (fromXML >=> return . Left)+++instance ToHTML Input where+   toHTML inp = mconcat+      [ panel $ barPos CenterLeft body+      ]+    where+      body = if null xs then space else spaced xs+      xs   = map (either text toHTML) (getInput inp)++defaultSolution :: [Input] -> Solution+defaultSolution inps = Solution+   { userId   = Nothing+   , groupId  = Nothing+   , language = Nothing+   , inputs   = inps+   }++instance HasId Input where+   getId = getInputId+   changeId f inp = inp { getInputId = f (getInputId inp) }++inputToString :: [Either MathML String] -> String+inputToString = unwords . map (either ppMathML id)++ppMathML :: MathML -> String+ppMathML = rec+ where+  rec :: MathML -> String+  rec math =+     case math of+        MRow ms           -> concatMap rec ms+        MId s             -> s+        MNumber s         -> s+        MOperator s       -> s+        MString s         -> s+        MText s           -> s+        MSqrt m           -> "sqrt (" ++ rec m ++ ")"+        MRoot m1 m2       -> "root (" ++ rec m1 ++ ") (" ++ rec m2 ++ ")"+        MSup m1 m2        -> ""++ rec m1 ++"^(" ++ rec m2 ++ ")"+        MSub m1 m2        -> rec m1 ++ rec m2+        MSubSup m1 m2 m3  -> ""++ rec m1 ++ rec m2 ++"^(" ++ rec m3 ++ ")"+        MFrac m1 m2       -> ""++ rec m1 ++"/(" ++ rec m2 ++ ")"+        MFenced s1 s2 m   -> s1 ++ rec m ++ s2+        MSpace            -> " "+        MStyle            -> ""+        MPadded           -> ""+        MPhantom          -> ""+        MError            -> ""+        MEnclose          -> ""+        MUnder            -> ""+        MOver             -> ""+        MUnderOver        -> ""+        MTable            -> ""+        MTableRow         -> ""+        MLabeledTableRow  -> ""+        MTableData        -> ""
+ src/Recognize/Data/Step.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.Step where++import Data.List+import Data.Semigroup+import Domain.Math.Expr+import Recognize.Data.Math+import Recognize.Data.Attribute+import Ideas.Common.Id+import Ideas.Text.HTML+import Ideas.Text.HTML.W3CSS+import Ideas.Text.XML hiding (Attribute)+import Util.W3CSSHTML++-- | A step is a small step, which describes some action by the math and attributes it carries+-- or it is a big step which is a grouping of other steps.+data Step = Step Id (Math, [Attribute]) [Step]+ deriving Eq++instance ToHTML (Step) where+ toHTML = text++instance Show Step where+ show (Step i a []) = show i ++ ": "++ show a+ show (Step i a ss) = show i ++ ": "++ show a ++ "\n" ++ unlines (map ('\t':) (lines (intercalate "\n" $ map show ss)))++instance HasId Step where+ getId (Step i _ _) = i+ changeId f (Step i b as) = Step (f i) b as++instance ToXML (Math, [Attribute]) where+ toXML (m,ats) = makeXML "stepcontent" $ mconcat [builderXML m, element "attributes" (map builderXML ats)]++instance ToXML Step where+ toXML (Step stepId stepValue steps) = makeXML "step" $ mconcat ("id".=. show stepId : builderXML stepValue : map builderXML steps)++smallStep :: Id -> (Math, [Attribute]) -> Step+smallStep i a = Step i a []++bigStep :: Id -> (Math, [Attribute]) -> [Step] -> Step+bigStep = Step++getValue :: Step -> (Math, [Attribute])+getValue (Step _ a _) = a++addAttribute :: Attribute -> Step -> Step+addAttribute a (Step i (m, attr) xs) = Step i (m, attr ++ [a]) xs++addAttributes :: [Attribute] -> Step -> Step+addAttributes xs s = foldl (flip addAttribute) s xs++hasMistakes :: Step -> Bool+hasMistakes = any isMistake . snd . getValue++makeFAStep :: Expr -> Step+makeFAStep e = smallStep (newId "final answer") (makeMath e, [FinalAnswer e])++getMath :: Step -> Math+getMath = fst . getValue++getMaths :: [Step] -> [Math]+getMaths = map getMath++getAttributes :: Step -> [Attribute]+getAttributes = snd . getValue++mergeSteps :: [Step] -> Maybe Step+mergeSteps [] = Nothing+mergeSteps (x:xs) = Just $ case mergeSteps xs of+  Nothing -> x+  Just y -> addAttributes (getAttributes x) y++stepsToHTML :: [Step] -> HTMLBuilder+stepsToHTML xs = tableAll $ mconcat (header : map (stepToHTML 0) xs)+ where+   header = tr (map (th . string) ["id", "attributes", "math"])++stepToHTML :: Int -> Step -> HTMLBuilder+stepToHTML indent (Step i (m,ats) xs) =+  tr (map td [ ( if null xs then id else bold) (string (replicate indent '-' ++ show i))+             , string (intercalate "," (map show ats))+             , toHTML m])+  <> mconcat (map (stepToHTML (indent + 1)) xs) -- indent
+ src/Recognize/Data/StringLexer.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.StringLexer where++import Data.Monoid ( (<>) )+import Ideas.Text.HTML                          hiding (table, ul)+import Ideas.Text.HTML.W3CSS                    hiding (input)+import Ideas.Text.XML hiding (tag)+import Recognize.Data.Solution+import Recognize.Data.StringLexerOptions+import Recognize.Parsing.MathLexer+import Util.Monad+import Util.W3CSSHTML+import Recognize.Preprocessing+import qualified Text.PrettyPrint.Leijen as PP++data LayoutMode = Column | Row+ deriving (Show, Eq)++instance ToXML LayoutMode where+ toXML Column = makeXML "layoutmode" $ string "column"+ toXML Row = makeXML "layoutmode" $ string "row"++-- | The LexerOutput contains the lexed strings and the layout mode which is determind by the columnizer in "Recognize.Parsing.MathLexer"+data LexerOutput = LexerOutput { stringLexerOutput :: [String], layoutMode :: LayoutMode }++instance Show LexerOutput where+   show = show . PP.pretty++instance PP.Pretty LexerOutput where+   pretty lo = PP.vcat $+      map PP.string (stringLexerOutput lo) +++      [ PP.string $ "Layout mode: " ++ show (layoutMode lo) ]++instance ToXML LexerOutput where+ toXML lo = makeXML "stringlexeroutput" $ mconcat+    [ string (unlines (stringLexerOutput lo))+    , builderXML (layoutMode lo)+    ]+++stringLexer :: StringLexerOptions -> Maybe Language -> Input -> LexerOutput+stringLexer opts lang i = let (ss,uc) = extract opts $ preProcess lang $ inputToString (getInput i)+                          in LexerOutput+                             { stringLexerOutput = ss+                             , layoutMode = if uc then Column else Row+                             }+++instance ToHTML LexerOutput where+   toHTML out =+      mWhen (not $ null $ stringLexerOutput out) (panel (w3list (map toHTML (stringLexerOutput out))))+      <> string ("layout mode: " ++ show (layoutMode out))
+ src/Recognize/Data/StringLexerOptions.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Data.StringLexerOptions+   ( StringLexerOptions, stringLexerOptions+   , variableWhitelist, replaceXByMultiplication+   ) where++import Data.Semigroup++-- | Parameters for "Recognize.Parsing.MathLexer"+data StringLexerOptions = Opts+ { variableWhitelist        :: [String] -- ^ Almost all natural language is removed. If some words need to be seen as variables then add them here+ , replaceXByMultiplication :: Bool+ }++stringLexerOptions :: StringLexerOptions+stringLexerOptions = Opts+   { variableWhitelist        = []+   , replaceXByMultiplication = False+   }++instance Semigroup StringLexerOptions where+   x <> y = Opts+      { variableWhitelist        = variableWhitelist x ++ variableWhitelist y+      , replaceXByMultiplication = replaceXByMultiplication x || replaceXByMultiplication y+      }++instance Monoid StringLexerOptions where+   mempty  = stringLexerOptions+   mappend = (<>)
+ src/Recognize/Expr/Functions.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Common functions on expressions or math types.+-- +-----------------------------------------------------------------------------++module Recognize.Expr.Functions where++import Control.Monad+import Data.Char                                (toLower)+import Data.Function                            (on)+import Data.Functor.Identity                    (runIdentity)+import Data.Generics.Str                        (strStructure)+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Ideas.Common.Rewriting hiding (hasVar)+import Ideas.Utils.Uniplate+import Recognize.Data.Math+import Recognize.Expr.Normalform+import Recognize.Expr.Symbols++-- | If there is a math that is a chained equation then split it up in a list of math types.+unchainAll :: [Math] -> ([Math], Bool)+unchainAll ms = (concat mss, or bs)+  where+    (mss, bs) = unzip (map f ms)++    f m = fromMaybe ([m], False) $ do+      Sym s xs <- getExpr m+      guard (s == chainedEqSymbol)+      let (eqs, b) = unchain xs+      return (map mk eqs, b)+      where+      mk eq = m {getResult = Right (toExpr eq)}++-- | From a list of expressions create a list of equations+unchain :: [Expr] -> ([Equation Expr], Bool)+unchain xs = (eqs, or bs)+  where+    (eqs, bs) = unzip (zipWith f xs (drop 1 xs))++    f x y =+      case getLeft y of+          Just ly | nf x /= nf y -> (x :==: ly, True)+          _ -> (x :==: y, False)++-- | gets the first found var if present+getVar :: Expr -> Maybe Expr+getVar = listToMaybe . mapMaybe f . universe+  where+    f e =+      case e of+        Var x -> Just $ Var x+        _ -> Nothing++-- | gets the string of the first found var if present+getVarS :: Expr -> Maybe String+getVarS e = do+  ve <- getVar e+  case ve of+    Var s -> return s+    _ -> Nothing++-- | Get the strings of all present vars in the expression+vars :: Expr -> [String]+vars e = concatMap f (universe e)+  where+    f (Var s) = [s]+    f _ = []++-- | Is a natural number+isNat :: Expr -> Bool+isNat (Nat _) = True+isNat _ = False++-- | Is a variable+isVar :: Expr -> Bool+isVar (Var _) = True+isVar _ = False++-- | Has a variable+hasVar :: Expr -> Bool+hasVar (Var _) = True+hasVar e = case getFunction e of+  Nothing -> False+  Just (_,xs) -> any hasVar xs++-- | Is a number+isNumber :: Expr -> Bool+isNumber (Number _) = True+isNumber _ = False++-- | Is a natural number, variable or number+isAtom :: Expr -> Bool+isAtom e = isNat e || isVar e || isNumber e++-- | Is a division+isDiv :: Expr -> Bool+isDiv (_ :/: _) = True+isDiv _ = False++-- | Has some expression as a subexpression+--+-- Check "Recognize.SubExpr" for more complicated cases+hasExpr :: Expr -> Expr -> Bool+hasExpr key e = key == e || case getFunction e of+  Nothing -> False+  Just (_,xs) -> any (hasExpr key) xs++-- | Given a list of expression and some target expression.+--+-- Return the expression that is closest to the target expression.+closestInList :: [Expr] -> Expr -> Maybe Expr+closestInList [] _ = Nothing+closestInList (x:xs) a =+  case closestInList xs a of+      Nothing -> return x+      Just y -- need a way to use abs on expressions+        | x > a && y > a && x < y -> return x+        | x > a && y > a -> return y+        | x < a && y < a && x > y -> return x+        | x < a && y < a -> return y+        | x > a && nf (x - a) < nf (a - y) -> return x+        | x > a -> return y+        | x < a && nf (a - x) < nf (y - a) -> return x+        | x < a -> return y+        | x == a -> return x+        | otherwise -> return y++-- | If the given expression is a binary operator+-- then replace its operator with plus,minus,times and division+-- otherwise return an empty list+changeOp :: Expr -> [Expr]+changeOp e =+    case children e of+      [x, y] -> map (\f -> f x y) bins+      _ -> []+  where+    bins = [(+), (-), (*), (/)]++-- | Determines whether two expressions share the same structure+-- without taking atomic values in consideration.  eg:  a + 6 == 4 + 2+equivalentStructure :: Expr -> Expr -> Bool+equivalentStructure a b = and $ zipWith f (universe a) (universe b)+  where+  f :: Expr -> Expr -> Bool+  f x y | isAtom x && isAtom y = True+        | isAtom x || isAtom y = False+        | otherwise = ((==) `on` (fst.runIdentity.getFunction)) x y++-- | Generate the atoms that are not equal between the two expressions+changeSet :: Expr -> Expr -> [(Expr, Expr)]+changeSet a b = foldl (\r (x,y) -> if isAtom x && isAtom y && x /= y then (x,y) : r else r) [] (zip (universe a) (universe b))++-- | Get the left or right argument of the direct children of the expression+getLeft, getRight :: Expr -> Maybe Expr+getLeft e = case children e of+                  x:_ -> Just x+                  _   -> Nothing+getRight e = case children e of+                  _:x:_ -> Just x+                  _     -> Nothing++-- | Traverse as far left as possible and return the found atom+getMostLeft :: Expr -> Maybe Expr+getMostLeft e = case getLeft e of+  Nothing -> Nothing+  Just x -> msum [getMostLeft x, Just x]++-- | Replace the left or right argument of the direct children of the expression+replaceLeft, replaceRight :: Expr -> Expr -> Expr+replaceLeft new e =+    let (str, f) = uniplate e+    in case strStructure str of+          (_:rest, g) -> f (g (new:rest))+          _ -> e+replaceRight new e =+    let (str, f) = uniplate e+    in case strStructure str of+          (x:_:rest, g) -> f (g (x:new:rest))+          _ -> e++-- | Round and simplify an expression to a specified precision+roundNumber :: Int -> Expr -> Expr+roundNumber d e@(Number _) = nf4 d e+roundNumber _ e = e++-- | Normalize the argument of a normalize expression+normalizeIfNF :: Expr -> Expr+normalizeIfNF e@(Sym s [e'])+  | isNormalformSymbol s = nf e'+  | otherwise = e+normalizeIfNF e = e
+ src/Recognize/Expr/Normalform.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- In this module we have defined several functions that produce some kind of normal form for an expression+-- Not all functions are used and they also often do not normalize as far as we would like.+-- Note that not all normalization functions defined in this project are defined in this module.+-- Sometimes specific normalizing functions are defined for a tool.+--+-----------------------------------------------------------------------------++module Recognize.Expr.Normalform+   ( nf, nf4, nfComAssoc, nfCom+   , rewriteSqrt, distributeExponent+   , ceilingExpr, floorExpr+   , roundDouble, doubleRoundedView+   , (===)+   ) where++import Util.Cache+import Data.Function+import Data.List+import Domain.Algebra.SmartGroup+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.Views+import Ideas.Common.Id+import Ideas.Common.Rewriting+import Ideas.Common.View as IV+import Ideas.Utils.Prelude+import Ideas.Utils.Uniplate++distributeExponent :: Expr -> Expr+distributeExponent e@(Sym s1 [x,i]) | isPowerSymbol s1+                    , Sym s2 [y,j] <- x+                    , isPowerSymbol s2+                    = Sym s1 [y,i .*. j]+distributeExponent e = e++rewriteSqrt :: Expr -> Expr+rewriteSqrt (Sqrt e) = Sym powerSymbol [e,1/2]+rewriteSqrt e = e++-- equality under normalisation+(===) :: Expr -> Expr -> Bool+a === b = nf2 a == nf2 b++-- | Note that the Ord instance for Expr is derived.+-- Because of this:   1:+:1 < 1:-:1+-- Therefore, comparison of Expr is not reliable when performed after nf.+-- since 3/2 cannot be normalized any further (but is bigger then 2)+nf :: Expr -> Expr+nf = cached "nf" $ \expr ->+   case expr of+      Sym s xs -> Sym s (map nf xs)+      -- nf (Sqrt e) = Sqrt (nf e)    -- < prevents actual simplification of square roots+      _ -> transform (simplify (polyViewWith rationalApproxView)) expr++nf2 :: Expr -> Expr+nf2 (Sym s xs) = Sym s (map nf2 xs)+nf2 e = simplify rationalApproxView e++-- | Simplifies with a certain precision+nf3 :: Int -> Expr -> Expr+nf3 n (Sym s xs) = Sym s $ map (nf3 n) xs+nf3 n e = simplify (doubleRoundedView (roundDouble n)) e++-- | Simplified with a certain precision if no variable present otherwise calls `nf`+nf4 :: Int -> Expr -> Expr+nf4 n e+    | hasSomeVar e = nfComAssoc $ nf e+    | otherwise = nf3 n e++doubleRoundedView :: (Double -> Double) -> View Expr Double+doubleRoundedView round = "num.double.rounded" @> doubleView >>> makeView (Just. round) id  --  . fix (matchDouble)) fromDouble++ceilingExpr :: Expr -> Expr+ceilingExpr (Number d) = Nat $ ceiling d+ceilingExpr e = e++floorExpr :: Expr -> Expr+floorExpr (Number d) = Nat $ floor d+floorExpr e = e++-- | Normalform for associativity+nfComAssoc :: Expr -> Expr+nfComAssoc = cached "nfComAssoc" $ \expr ->+   case expr of+      -- Rewrites a Number to a division+      Number _ -> nf expr+      _ ->+         case (from sumView expr, from productView expr) of+            (xs, _) | length xs > 1 ->+               to sumView $ sortBy (compare `on` nf) (map nfComAssoc xs)+            (_, (b, xs)) | length xs > 1 ->+               to productView (b, sortBy (compare `on` nf) (map nfComAssoc xs))+            _ ->+               descend nfComAssoc expr++-- | normal form for commutativity +/*+nfCom :: Expr -> Expr+nfCom = cached "nfCom" $ \expr ->+   case expr of+      _ :+: _ -> sum (sort (map nfCom (collect expr)))+       where+         collect (x :+: y) = collect x ++ collect y+         collect (x :-: y) = collect x ++ map neg (collect y)+         collect (Negate x) = map neg (collect x)+         collect a = [a]+      x :*: y  -- we need to collect here as well?  (3 * 2 * 1 -> 2 * 3 * 1)+         | x' <= y'  -> x' :*: y'+         | otherwise -> y' :*: x'+       where+         x' = nfCom x+         y' = nfCom y+      Number _ -> simplify rationalApproxView expr+      _ -> descend nfCom expr++-- | Round a double with a specified precision+--+-- Unlike the `round` function in prelude, this function will round up if the decimal is >=5 and otherwise down+roundDouble :: Int -> Double -> Double+roundDouble n d = fromIntegral (roundNearest (d * 10Prelude.^n)) / 10Prelude.^n++-- The `round` function in prelude rounds with regard to the equidistance of the argument+roundNearest :: (RealFrac a, Integral b) => a -> b+roundNearest a = let (n,r) = properFraction a+                  in if r >= 0.5 then n + 1 else n
+ src/Recognize/Expr/Symbols.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Extends the `Expr` data type by creating new symbols.+-- +-----------------------------------------------------------------------------++module Recognize.Expr.Symbols where++import Domain.Math.Expr+import Domain.Math.Data.Relation+import Ideas.Common.Rewriting++-- | Approximates to a certain precision+approxSymbol :: Symbol+approxSymbol = newSymbol "approx"++-- | Stores a degree of precision along side the expression+approx :: Integer -> Expr -> Expr+approx p e = Sym approxSymbol [Nat p, e]++-- | Matches anything+wildcardSymbol :: Symbol+wildcardSymbol = newSymbol "wildcard"++isWildcardSymbol :: Symbol -> Bool+isWildcardSymbol = (==wildcardSymbol)++-- | Use this to match anything+--+-- Only works though if the used comparison function is aware of the symbol+wildcard :: Expr+wildcard = Sym wildcardSymbol []++wildcardRelation :: Relation Expr+wildcardRelation = wildcard .==. wildcard++-- | An identifiable wildcard+namedWildcardSymbol :: Symbol+namedWildcardSymbol = newSymbol "namedWildcard"++isNamedWildcardSymbol :: Symbol -> Bool+isNamedWildcardSymbol = (==namedWildcardSymbol)++-- Create an identifiable wildcard+namedWildcard :: String -> Expr+namedWildcard s = Sym namedWildcardSymbol [Var s]++-- | Symbol for normalizing expressions+normalformSymbol :: Symbol+normalformSymbol = newSymbol "normalform"++isNormalformSymbol :: Symbol -> Bool+isNormalformSymbol = (==normalformSymbol)++-- | The contained expression will be normalized at some point+normalform :: Expr -> Expr+normalform e = Sym normalformSymbol [e]
+ src/Recognize/Model/Assess.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines some common functions used in the exercise specific assessment functions.+--+-----------------------------------------------------------------------------++module Recognize.Model.Assess+   ( -- * Generate evidence+     generateEvidence, answerCorrect, stringNode+     -- * Failure constraints+   , failOnInvalidEquationAny, failOnInvalidEquation, failOnIncorrectDistribution, failOnCommonMistake+   , failOnUnequalRelationAny, failOnUnequalRelation, failOnAtomMixedUpAny, failOnAnyMistake+   , withoutFailure+     -- * Evidence collecting+   , giveNodeAndCollect, giveNodeAndCollectAll, giveNodeAndCollectAllKnown, giveNodeAndCollectDefault+   ) where++import Control.Monad.Identity+import Control.Monad.State+import Data.Either+import Data.Maybe+import Data.Monoid+import Data.List+import Domain.Math.Expr+import Domain.Math.Data.Relation+import Ideas.Utils.Uniplate+import Recognize.Model.Constraint+import Recognize.Model.EvidenceBuilder+import Recognize.Model.Result+import Bayes.Evidence+import Recognize.Data.Approach+import Recognize.Data.Attribute+import Recognize.Model.Connectives+import Recognize.Expr.Normalform+import Recognize.Expr.Symbols+import Recognize.Expr.Functions+import Bayes.Network+import Util.List++-- | Generic function for gathering evidence+generateEvidence :: (Approach -> EvBuilder ()) -- ^ Function for building the evidence+              -> Approach -- ^ Category of solution+              -> [[Attribute]] -- ^ Collected attributes to use as input+              -> Evidence+generateEvidence feb appr = buildEvidence (feb appr)++--Produce evidence for the correct answer from the attributes, with the correct answer being the given expression+answerCorrect :: Expr -> [[Attribute]] -> Node Bool -> Evidence+answerCorrect ans attrs aC = mconcat (catMaybes [ verifyConstraintI (answerConstraint ans aC) (concat attrs)])++--Produce evidence for a string Node based on a string:+stringNode :: Maybe String -> Node String -> Evidence+stringNode (Just s) n = n .== s+stringNode Nothing _  = mempty++--Constraint that checks if a finalanswer matches the given expression+answerConstraint :: Expr -> Node Bool -> NodeConstraint Bool Identity [Attribute]+answerConstraint fa aC =+  makeNodeConstraint aC $ \xs -> return $+    case xs of+      _ | FinalAnswer fa `elem` xs -> Success+        | hasFA xs -> Failure+        | otherwise -> Unknown+    where+      hasFA xs = isJust $ find (\attr -> case attr of+                        FinalAnswer _ -> True+                        _ -> False) xs++-- | Generates a failure if some InvalidEquation attribute is present+failOnInvalidEquationAny :: Constraint EvBuilder [Attribute]+failOnInvalidEquationAny = negateConstraint (exists1 $ InvalidEquation wildcard wildcard)++-- | Generates a failure if an InvalidEquation attribute with the two specified expression is present+failOnInvalidEquation :: Expr -> Expr -> Constraint EvBuilder [Attribute]+failOnInvalidEquation e1 e2 = negateConstraint (exists1 $ InvalidEquation e1 e2)++-- | Generates a failure if the IncorrectDistribution attribute or the NonMatchingParenthese attribute is present+failOnIncorrectDistribution :: Constraint EvBuilder [Attribute]+failOnIncorrectDistribution = negateConstraint (exists1 IncorrectDistribution <||> exists1 NonMatchingParentheses)++-- | Generates a failure if the CommonMistake attribute is present+failOnCommonMistake :: Constraint EvBuilder [Attribute]+failOnCommonMistake = negateConstraint (exists1 CommonMistake)++-- | Generates a failure if the UnequalRelations attribute with the two specified relations is present+failOnUnequalRelation :: Relation Expr -> Relation Expr -> Constraint EvBuilder [Attribute]+failOnUnequalRelation rel1 rel2 = negateConstraint (exists1 $ UnequalRelations rel1 rel2)++-- | Generates a failure if the UnequalRelations attribute is present+failOnUnequalRelationAny :: Constraint EvBuilder [Attribute]+failOnUnequalRelationAny = failOnUnequalRelation wildcardRelation wildcardRelation++-- | Generates a failure if the AtomMixedUp attribute is present+failOnAtomMixedUpAny :: Constraint EvBuilder [Attribute]+failOnAtomMixedUpAny = negateConstraint (exists1 $ AtomMixedUp wildcard wildcard)++-- | Combines all the above mentioned failure functions+failOnAnyMistake :: Constraint EvBuilder [Attribute]+failOnAnyMistake = failOnCommonMistake <> failOnInvalidEquationAny <> failOnUnequalRelationAny <> failOnAtomMixedUpAny <> failOnIncorrectDistribution++-- | Combines the given constraint with the constraint that there should be no failures+withoutFailure :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+withoutFailure c = c ==> (failOnAnyMistake <?>> mempty)++-- | Collect/Store evidence generated by a node constraint+collect :: Verifiable b => NodeConstraint b EvBuilder [Attribute] -> EvBuilder ()+collect c = verifyConstraint c >>= storeEvidenceMaybe++-- | Collect/Store evidence generated by a node constraint+-- If the evidence is unknown then we assign a value to the given assessment variable+collectDefault :: Verifiable b => NodeConstraint b EvBuilder [Attribute] -> Expr -> Expr -> EvBuilder ()+collectDefault c var new = do+  mev <- verifyConstraint c+  val <- (nfComAssoc . normalizeIfNF) <$> transformM getValueOf new+  replaceWhenUnknown mev var val+  storeEvidenceMaybe mev++replaceWhenUnknown :: Maybe a -> Expr -> Expr -> EvBuilder ()+replaceWhenUnknown Nothing var new = setValueOf var new+replaceWhenUnknown _ _ _ = return ()++-- | Takes the given constraint, couples it to the node and stores the evidence.+giveNodeAndCollect :: Verifiable b => Node b -> Constraint EvBuilder [Attribute] -> EvBuilder ()+giveNodeAndCollect n c = do+  let nodeconstraint = giveNode n c+  collect nodeconstraint++-- | Useful when multiple constraints spread over multiple steps have to be verified.+-- Takes the given constraints and couples them to the node.+-- The evidence is true if ALL given results are successful. (= no unknwon results)+-- The evidence is false if ANY known result is false.+-- The evidence is unknown if all known results are succesful, but there are unknown results.+giveNodeAndCollectAll :: Verifiable b => Node b -> [Constraint EvBuilder [Attribute]] -> EvBuilder ()+giveNodeAndCollectAll n cs = do+  evs <- mapM (verifyConstraint . giveNode n) cs+  let knownEvs = lefts (map snd (concatMap fromEvidence (catMaybes evs)))+  let nodeconstraint | 1 `elem` knownEvs = giveNode n failure+                     | any isNothing evs = giveNode n unknown+                     | otherwise = giveNode n success+  storeEvidenceMaybe (verifyConstraintI nodeconstraint [])++-- | Useful when multiple constraints spread over multiple steps have to be verified.+-- Takes the given constraints and couples them to the node.+-- The evidence is true if ALL known results are successful.+-- The evidence is false if ANY known result is false.+-- The evidence is unknown if there are no known results.+giveNodeAndCollectAllKnown :: Verifiable b => Node b -> [Constraint EvBuilder [Attribute]] -> EvBuilder ()+giveNodeAndCollectAllKnown n cs = do+  evs <- mapM (verifyConstraint . giveNode n) cs+  let knownEvs = lefts (map snd (concatMap fromEvidence (catMaybes evs)))+  let nodeconstraint | null knownEvs = giveNode n unknown+                     | 1 `elem` knownEvs = giveNode n failure+                     | otherwise = giveNode n success+  storeEvidenceMaybe (verifyConstraintI nodeconstraint [])++-- | Takes the given constraint, couples it to the node and stores the evidence.+-- If the evidence is unknown then we assign a value to the given assessment variable+giveNodeAndCollectDefault :: Verifiable b => Node b -> Constraint EvBuilder [Attribute] -> Expr -> Expr -> EvBuilder ()+giveNodeAndCollectDefault n c var new = do+  let nodeconstraint = giveNode n c+  collectDefault nodeconstraint var new+  +-- | Type class for all types of nodes that we can verify using a constraint.+class Verifiable b where+    verifyConstraint :: NodeConstraint b EvBuilder [Attribute] -> EvBuilder (Maybe Evidence) -- ^ Verify a node constraint using the evidence builder.+    verifyConstraintI :: NodeConstraint b Identity [a] -> [a]-> Maybe Evidence -- ^ Verify a node constraint without consuming attributes.++instance Verifiable Bool where+    verifyConstraint c = do+           attrs <- getAttributesPerStep+           -- For each step that produced attributes we attempt to verify the constraint with+           mi <- returnOnJustM (\a -> do+              st <- get+              res <- getResult (getConstraint c) a+              when (isUnknown res) $ put st+              return $ resultToBool res) attrs+           case mi of+              Nothing -> do+                 r <- getResult (getConstraint c) []+                 return (resultToBool r >>= \i -> return $ getNode c .== i)+              Just (i,attrs') -> do+                 putAttributes attrs'+                 return $ Just $ getNode c .== i++    verifyConstraintI c attrs =+       case resultToBool $ runIdentity $ getResult (getConstraint c) attrs of+          Nothing -> Nothing+          Just i  -> Just $ getNode c .== i+          +instance Verifiable (Maybe Bool) where+    verifyConstraint c = do+           attrs <- getAttributesPerStep+           -- For each step that produced attributes we attempt to verify the constraint with+           mi <- returnOnJustM (\a -> do+              st <- get+              res <- getResult (getConstraint c) a+              when (isUnknown res) $ put st+              return $ resultToBool res) attrs+           case mi of+              Nothing -> do+                 r <- getResult (getConstraint c) []+                 return (resultToBool r >>= \i -> return $ getNode c .== (Just i))+              Just (i,attrs') -> do+                 putAttributes attrs'+                 return $ Just $ getNode c .== (Just i)++    verifyConstraintI c attrs =+       case resultToBool $ runIdentity $ getResult (getConstraint c) attrs of+          Nothing -> Nothing+          Just i  -> Just $ getNode c .== (Just i)
+ src/Recognize/Model/Connectives.hs view
@@ -0,0 +1,256 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines functions and operators for constructing and combining constraints.+--+-----------------------------------------------------------------------------++module Recognize.Model.Connectives+   ( -- * Constructing constraints+     success, unknown, failure, exists1, exists, existsF1, existsF, implication+     -- * Combinators+   , negateConstraint+   , (<||>), (<?>>), (<<?>), (==>), (<~>)+   ) where++import Control.Monad+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Ideas.Common.Rewriting.Term+import Ideas.Utils.Uniplate+import Recognize.Data.Attribute+import Recognize.Expr.Normalform+import Recognize.Expr.Symbols+import Recognize.Expr.Functions+import Recognize.Model.Constraint+import Recognize.Model.EvidenceBuilder+import Recognize.Model.Result            as R+import Util.Monad+import qualified Data.List.NonEmpty as N++-- | Constraint with an always succesful predicate+success :: Monad m => Constraint m a+success = Constraint $ \_ -> return Success++-- | Constraint whose predicate is always unknown+unknown :: Monad m => Constraint m a+unknown = Constraint $ \_ -> return Unknown++-- | Constraint whose predicate is always failure+failure :: Monad m => Constraint m a+failure = Constraint $ \_ -> return Failure++-- | If the attribute is present the constraint holds+--+-- otherwise we do not know+exists1 :: Attribute -> Constraint EvBuilder [Attribute]+exists1 = exists . (:[])++-- | If all attributes are present the constraint holds+--+-- otherwise we do not know+exists :: [Attribute] -> Constraint EvBuilder [Attribute]+exists hyps = implication hyps []++-- | If the attribute is present the constraint holds+--+-- otherwise it does not+existsF1 :: Attribute -> Constraint EvBuilder [Attribute]+existsF1 = implication [] . (:[])++-- | If all attributes are present the constraint holds+--+-- otherwise it does not+existsF :: [Attribute] -> Constraint EvBuilder [Attribute]+existsF = implication []++-- | If all hypotheses are present and all conclusions are present then the constraint holds+--+-- If all hypotheses are present, but not all conclusions are present then the constraint does not hold+--+-- If not all hypotheses are present then we do not know+implication :: [Attribute] -- ^ Hypotheses+            -> [Attribute] -- ^ Conclusions+            -> Constraint EvBuilder [Attribute]+implication hyps concs = Constraint $ \xs -> do+  ht <- hypsTrue xs+  ct <- concsTrue xs+  detResult (ht,ct)+  where+    detResult (ht,ct) =+      case (ht,ct) of+        (True,True) -> return Success+        (True,_) -> return Failure+        _ -> return Unknown+    hypsTrue xs  = allM (`elemM` xs) hyps+    concsTrue xs = allM (`elemM` xs) concs+    elemM x = anyM $ \y -> do+      vs <- getVariables+      b  <- compareAttribute x y+      unless b $ putVariables vs+      return b++-- | Negate the results of the predicate within a constraint.+negateConstraint :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+negateConstraint c = Constraint $ \xs -> fmap R.negate (getResult c xs)++-- Or for constraints+(<||>) :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+c1 <||> c2 = Constraint $ \xs -> do+  r1 <- getResult c1 xs+  case r1 of+    Success -> return Success+    Failure -> getResult c2 xs+    Unknown -> do+      r2 <- getResult c2 xs+      case r2 of+        Success -> return Success+        _ -> return Unknown++-- | If the first constraint is unknown then we return the result of the second constraint+(<?>>) :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+c1 <?>> c2 = Constraint $ \xs -> do+  r1 <- getResult c1 xs+  case r1 of+    Unknown -> getResult c2 xs+    _ -> return r1++-- | If the second constraint is unknown then we return the result of the first constraint+(<<?>) :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+c1 <<?> c2 = Constraint $ \xs -> do+  r2 <- getResult c2 xs+  case r2 of+    Unknown -> getResult c1 xs+    _ -> return r2++-- | Implication over constraints+--+-- If the first constraint holds then the result of this operation is equal to that of the second constraint+--+-- otherwise we do not know whether this constraint holds+(==>) :: Constraint EvBuilder [Attribute]  -> Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]+c1 ==> c2 = Constraint $ \xs -> do+  r1 <- getResult c1 xs+  case r1 of+    Success -> getResult c2 xs+    _ -> return Unknown++-- | Equality constraint between two expressions+-- Does not consume any input+(<~>) :: Expr -> Expr -> Constraint EvBuilder a+e1 <~> e2 = Constraint $ \_ -> do+  b <- compareExpr' e1 e2+  if b then return Success+       else return Failure+++-- | Compares two attributes for equality+compareAttribute :: Attribute -> Attribute -> EvBuilder Bool+compareAttribute (ARule r1 b1 a1) (ARule r2 b2 a2) = do+  lb1b2 <- zipWithM compareExpr lb1 lb2+  a1a2 <- compareExpr a1 a2+  return $ and lb1b2 && a1a2 && r1 == r2 && length lb1 == length lb2+  where+    lb1 = N.toList b1+    lb2 = N.toList b2+compareAttribute (ARuleR r1 b1 a1) (ARuleR r2 b2 a2) = do+  lb1b2 <- compareExpr (leftHandSide  b1) (leftHandSide  b2)+  rb1b2 <- compareExpr (rightHandSide b1) (rightHandSide b2)+  la1a2 <- compareExpr (leftHandSide  a1) (leftHandSide  a2)+  ra1a2 <- compareExpr (rightHandSide a1) (rightHandSide a2)+  let b1b2rel = relationType b1 == relationType b2+      a1a2rel = relationType a1 == relationType a2+  return $ r1 == r2 && lb1b2 && rb1b2 && la1a2 && ra1a2 && b1b2rel && a1a2rel+compareAttribute (InvalidEquation b1 a1) (InvalidEquation b2 a2) = do+  b <- compareExpr b1 b2+  a <- compareExpr a1 a2+  return (b && a)+compareAttribute (UnequalRelations b1 a1) (UnequalRelations b2 a2) = do+  lb1b2 <- compareExpr (leftHandSide b1) (leftHandSide  b2)+  rb1b2 <- compareExpr (rightHandSide b1) (rightHandSide b2)+  la1a2 <- compareExpr (leftHandSide  a1) (leftHandSide  a2)+  ra1a2 <- compareExpr (rightHandSide a1) (rightHandSide a2)+  return $ lb1b2 && rb1b2 && la1a2 && ra1a2+compareAttribute (MatchedBy a1 b1) (MatchedBy a2 b2) = do+  b <- compareExpr b1 b2+  a <- compareExpr a1 a2+  return (a && b)+compareAttribute (LabelE l1 e1) (LabelE l2 e2) = do+  b <- compareExpr e1 e2+  return (l1 == l2 && b)+compareAttribute (FinalAnswer e1) (FinalAnswer e2) =+  compareExpr e1 e2+compareAttribute (AtomMixedUp a1 b1) (AtomMixedUp a2 b2) = do+  a <- compareExpr a1 a2+  b <- compareExpr b1 b2+  return (a && b)+compareAttribute a1 a2 = return $ a1 == a2++-- Substitute any possible named wildcards with their respective values and then compare+-- For other expressions their expressions themselves are used+compareExpr :: Expr -> Expr -> EvBuilder Bool+compareExpr e1 e2 = do+  e1Val <- normalizeIfNF <$> transformM getValueOf e1+  e2Val <- normalizeIfNF <$> transformM getValueOf e2+  compareExpr' (nfComAssoc e1Val) (nfComAssoc e2Val)++-- | Compares two expressions for equality. Takes into account variables and wildcards.+compareExpr' :: Expr -> Expr -> EvBuilder Bool+compareExpr' (Number d1) (Number d2) = return (d1 == d2)+compareExpr' (Var v1) (Var v2) = return (v1 == v2)+compareExpr' (Nat n1) (Nat n2) = return (n1 == n2)+compareExpr' (Nat _) (Sym s [])+  | isWildcardSymbol s = return True+  | otherwise = return False+compareExpr' e1@(Nat _) (Sym s [Var n])+  | isNamedWildcardSymbol s = updateVar n e1 >> return True+  | otherwise = return False+compareExpr' (Sym s [Var n]) e2@(Nat _)+  | isNamedWildcardSymbol s = updateVar n e2 >> return True+  | otherwise = return False+compareExpr' (Sym s []) (Nat _)+  | isWildcardSymbol s = return True+  | otherwise = return False+compareExpr' (Var _) (Sym s [])+  | isWildcardSymbol s = return True+  | otherwise = return False+compareExpr' e1@(Var _) (Sym s [Var n])+  | isNamedWildcardSymbol s = updateVar n e1 >> return True+  | otherwise = return False+compareExpr' (Sym s [Var n]) e2@(Var _)+  | isNamedWildcardSymbol s = updateVar n e2 >> return True+  | otherwise = return False+compareExpr' (Sym s []) (Var _)+  | isWildcardSymbol s = return True+  | otherwise = return False+compareExpr' e1 e2 =+  let (s1, es1) = fromMaybe (wildcardSymbol, []) (getFunction e1)+      (s2, es2) = fromMaybe (wildcardSymbol, []) (getFunction e2)+  in+    if isWildcardSymbol s1 && s1 == s2 then return (e1 == e2)+     else case (getFunction e1, getFunction e2) of+      (Just (s,[Var n]),_)+        | isNamedWildcardSymbol s -> updateVar n e2 >> return True+      (_,Just (s,[Var n]))+        | isNamedWildcardSymbol s -> updateVar n e1 >> return True+      (Just (s,_),_)+        | isWildcardSymbol s -> return True+      (_,Just (s,_))+        | isWildcardSymbol s -> return True+      (Just (s,[Nat p, e]),_)+        | s == approxSymbol -> compareExpr' (nf4 (fromIntegral p) e) (nf4 (fromIntegral p) e2)+      (_,Just (s,[Nat p, e]))+        | s == approxSymbol -> compareExpr' (nf4 (fromIntegral p) e1) (nf4 (fromIntegral p) e)+      (_,_) ->+        if s1 == s2 then do+          es1es2 <- zipWithM compareExpr' es1 es2+          return $ and es1es2+         else return False
+ src/Recognize/Model/Constraint.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the constraint data types.+-- We differentiate between two constraint types:+-- +-- * Node constraint+-- * regular constraint+-- +-- The regular constraint consists of a set of identifiers+-- and a function that consumes some type @a@ and produces a `Result`.+-- The set of identifiers come from combining constraints using the connectives+-- defined in "Connectives".+-- +-- A Node constraint is simply a product of a Node Bool (the node) and a regular constraint.+-- The constraint then corresponds to a node in one of the networks.+--+-----------------------------------------------------------------------------++module Recognize.Model.Constraint where++import Data.Monoid+import qualified Data.Semigroup as SG+import Recognize.Model.EvidenceBuilder+import Recognize.Model.Result+import Bayes.Network (Node)++-- | Wraps over a constraint by giving it a specific node+data NodeConstraint b m a = NodeConstraint+  { getNode :: Node b -- ^ The node of a constraint+  , getConstraint :: Constraint m a -- ^ The underlying constraint+  }++-- | Models constraints that have an identifier and describe predicates that produce a result+data Constraint m a = Constraint+  {+    getResult :: a -> m Result -- ^ Predicates that produces a `Result` given an @a@+  }++-- | Couple a constraint to a specific Node+giveNode :: Node b -> Constraint m a -> NodeConstraint b m a+giveNode = NodeConstraint++-- | Makes a nodeconstraint:+makeNodeConstraint :: Node b -> (a -> m Result) -> NodeConstraint b m a+makeNodeConstraint node = NodeConstraint node . Constraint++instance SG.Semigroup (Constraint EvBuilder a) where+   (Constraint mr1) <> (Constraint mr2) = Constraint (combinePredicates mr1 mr2)++instance Monoid (Constraint EvBuilder a) where+  mempty = Constraint (\_ -> return Success)+  mappend = (SG.<>)++-- | Combines two predicates into one+combinePredicates :: (a -> EvBuilder Result) -> (a -> EvBuilder Result) -> a -> EvBuilder Result+combinePredicates rm1 rm2 a = do+  r1 <- rm1 a+  r2 <- rm2 a+  return (r1 <> r2)
+ src/Recognize/Model/EvidenceBuilder.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- This module describes the underlying mechanism for generating evidence given constraints over attributes.
+--
+-----------------------------------------------------------------------------
+
+module Recognize.Model.EvidenceBuilder
+   ( EvBuilder
+   , putAttributes, updateVar, getValueOf
+   , setValueOf, storeEvidenceMaybe, buildEvidence, newVar
+   , getAttributesPerStep, getVariables, putVariables
+   ) where
+
+import Control.Monad.State
+import Data.Semigroup
+import qualified Data.Map as M
+import Domain.Math.Expr
+import Recognize.Data.Attribute
+import Bayes.Evidence
+import Recognize.Expr.Symbols
+
+-- | Builder that consumes attributes and produces evidence.
+-- It Maintains a quadruple state:
+--
+--    1. Evidence               -- The generated evidence
+--    2. [[Attribute]]          -- Remaining Attributes per step
+--    3. M.Map String Expr      -- Maps variable names to expressions
+newtype EvBuilder a = EvBuilder (State EvState a)
+
+data EvState = EvState
+   { evidence    :: Evidence
+   , attributes  :: [[Attribute]]
+   , variables   :: M.Map String Expr
+   }
+
+instance Functor EvBuilder where
+  fmap f m = pure f <*> m
+
+instance Applicative EvBuilder where
+  pure = return
+  (<*>) = ap
+
+instance Semigroup (EvBuilder a) where
+  EvBuilder ev1 <> EvBuilder ev2 = EvBuilder $ do
+    st <- get
+    if null $ fromEvidence $ evidence $ execState ev1 st
+      then ev2
+      else ev1
+
+instance Monad EvBuilder where
+  return = EvBuilder . return
+  EvBuilder m >>= f = EvBuilder $ do
+    a <- m
+    let EvBuilder x = f a
+    x
+
+instance MonadState EvState EvBuilder where
+  get = EvBuilder get
+  put s = EvBuilder $ put s
+
+-- | Creates a new wildcard variable
+newVar :: String -> EvBuilder Expr
+newVar s = do
+  let mn = namedWildcard s
+  updateVar s mn
+  return mn
+
+-- | Give an existing variable a new value
+updateVar :: String -> Expr -> EvBuilder ()
+updateVar s v = EvBuilder $ modify $ \st ->
+   st { variables = M.insert s v $ variables st }
+
+-- | Retrieve the value belonging to a variable
+getValueOf :: Expr -> EvBuilder Expr
+getValueOf e@(Sym s [Var n]) = EvBuilder $ do
+  m <- gets variables
+  case (isNamedWildcardSymbol s,M.lookup n m) of
+    (True,Just e') -> return e'
+    _ -> return e
+getValueOf e = return e
+
+-- | Expr wrapper over `updateVar`
+setValueOf :: Expr -> Expr -> EvBuilder ()
+setValueOf (Sym _ [Var n]) v = updateVar n v
+setValueOf _ _ = return ()
+
+buildEvidence :: EvBuilder () -> [[Attribute]] -> Evidence
+buildEvidence (EvBuilder m) attrs =
+   evidence $ execState m $ EvState mempty attrs M.empty
+
+-- | Adds evidence to the state
+storeEvidence :: Evidence -> EvBuilder ()
+storeEvidence ev = EvBuilder $ modify $ \st ->
+   st { evidence = evidence st <> ev }
+
+storeEvidenceMaybe :: Maybe Evidence -> EvBuilder ()
+storeEvidenceMaybe = maybe (return ()) storeEvidence
+
+-- | Replaces the attributes in the state
+putAttributes :: [[Attribute]] -> EvBuilder ()
+putAttributes attrs = EvBuilder $ modify $ \st -> st { attributes = attrs }
+
+getAttributesPerStep :: EvBuilder [[Attribute]]
+getAttributesPerStep = EvBuilder $ gets attributes
+
+getVariables :: EvBuilder (M.Map String Expr)
+getVariables = EvBuilder $ gets variables
+
+putVariables :: M.Map String Expr -> EvBuilder ()
+putVariables vs = EvBuilder $ modify $ \st -> st { variables = vs }
+ src/Recognize/Model/Result.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Model.Result where++import Data.Semigroup++-- | Describes the possible results of the predicate of a constraint+data Result =+  Success -- ^ The predicate was true+  | Failure -- ^ The predicate was false+  | Unknown -- ^ We don't know whether the predicate is true or false+  deriving (Eq, Show)++instance Semigroup Result where+  Success <> Success = Success+  Success <> r2 = r2+  r1 <> Success = r1+  Unknown <> Unknown = Unknown+  _ <> Failure = Failure+  Failure <>  _ = Failure++instance Monoid Result where+   mempty  = Success+   mappend = (<>)++resultToBool :: Result -> Maybe Bool+resultToBool Success = Just True+resultToBool Failure = Just False+resultToBool Unknown = Nothing++isUnknown :: Result -> Bool+isUnknown Unknown = True+isUnknown _ = False++negate :: Result -> Result+negate Success = Failure+negate Failure = Success+negate Unknown = Unknown
+ src/Recognize/Parsing/Derived.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module exports a set of functions that build upon the primitives from "Recognizer.Common.Parsing.Parse"+-- +-----------------------------------------------------------------------------++module Recognize.Parsing.Derived+   ( choice, skip, peek, maybeToParse, peek2, choice'+   , choiceFor, choiceFor', succeedIf, pFoldAlt+   , few, satisfyEq, pInOrder, pRepeat, withInput+   , pInOrderAll, getInputSize, getBinary, many1, pSkipUntil+   , many', many1', pAnyExpr, pReplicate, pAnyOf, pSomewhere+   , pAnywhere, nonEmpty, pRewrite, peekExpr, peekEq, pExprWith+   , succeed, pEq, pEqCom, pExprCom, pExpr+   ) where++import Control.Applicative+import Control.Monad+import Data.List+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr hiding (pExpr)+import Ideas.Common.Rewriting (getFunction)+import Ideas.Common.View+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Expr.Normalform+import Recognize.Parsing.Parse++-- | Skips a single input+skip :: Parse m s => m s+skip = satisfy (const True)++-- | Synonym for `pure` and `return`+succeed :: Parse m s => a -> m a+succeed = pure++-- | Greedy version of `many`+many' :: Parse m s => m a -> m [a]+many' p = (:) <$> p <*> many' p+                  |> succeed []++-- | Perform one parsing followed by `many`+many1 :: Parse m s => m a -> m [a]+many1 p = (:) <$> p <*> many p++-- | Greedy version of `many1`+many1' :: Parse m s => m a -> m [a]+many1' p = (:) <$> p <*> many' p++-- | Alternative to `many` where the order of the branches is reversed.+--+-- Here the first branch is an always successful parsing, the 2nd branch does one parsing+--+-- The third does two parsings and so on..+--+-- A common usage:+--+-- >>> p >> few skip >> q+--+-- We want to parse @q@ and close as possible to @p@, but we do not mind skipping as much as necessary.+few :: Parse m s => m a -> m [a]+few p = return [] <|> ((:) <$> p >> few p)++-- | Fails if the resulting list is empty+nonEmpty :: Parse m s => m [a] -> m [a]+nonEmpty p = do xs <- p+                when (null xs) empty+                return xs++-- | Fold over <|>+choice :: Parse m s => [m a] -> m a+choice = foldl (<|>) empty++-- | Fold over |>+choice' :: Parse m s => [m a] -> m a+choice' = foldl (|>) empty++-- | Combination of choice and for+choiceFor :: Parse m s => [a] -> (a -> m b) -> m b+choiceFor as f = foldl (\acc a -> acc <|> f a) empty as++-- | Combination of choice' and for+choiceFor' :: Parse m s => [a] -> (a -> m b) -> m b+choiceFor' as f = foldl (\acc a -> acc |> f a) empty as++-- | Fails if predicate doesn't hold+succeedIf :: Parse m s => (a -> Bool) -> a -> m a+succeedIf p a | p a = return a+              | otherwise = empty++-- | Apply a function to the remaining input and return the result+--+-- Does not parse input.+withInput :: Parse m s => ([s] -> a) -> m a+withInput f = withInputList (return . f)++getInputSize :: Parse m s => m Int+getInputSize = withInput length++-- | Fails on Nothing. Succeeds on Just.+maybeToParse :: Parse m s => Maybe a -> m a+maybeToParse Nothing = empty+maybeToParse (Just a) = succeed a++-- | Returns the head of input. Fails if there is none.+peek :: Parse m s => m s+peek = do+  ms <- safePeek+  case ms of+    Nothing -> empty+    Just s -> return s++-- | Returns the top two inputs. Fails if there are less than 2 input remaining.+peek2 :: Parse m s => m (s, s)+peek2 = do+  ss <- withInput id+  case ss of+    (x:y:_) -> return (x,y)+    _ -> empty++-- | Continuously skip input until parsing succeeds.+pSkipUntil :: Parse m s => m a -> m (a,[s])+pSkipUntil p = ((\a -> (a,[])) <$> p) |> (skip >>= \s -> second (s:) <$> pSkipUntil p)++-- | Similar to `pFold`, except that we only return the last computed result+pFoldAlt' :: (Parse m s, Show a) => (a -> m a) -> a -> m a+pFoldAlt' f a = do+  a' <- f a+  pFoldAlt' f a' <|> return a'++-- | Only calls `pFoldAlt'` if the predicate is True. Otherwise parses once.+pFoldAlt :: (Parse m s, Show a) => Bool -> (a -> m a) -> a -> m a+pFoldAlt b f a+  | b = pFoldAlt' f a+  | otherwise = f a++-- | Skip input until a successful parsing+pSomewhere :: Parse m s => m a -> m a+pSomewhere p = p |> (skip *> pSomewhere p)++-- | Skip input until a successful parsing. Skip all remaining input.+pAnywhere :: Parse m s => m a -> m a+pAnywhere p = do+   x <- pSomewhere p+   _ <- many' skip+   return x++-- | Skip input until one of the parsers succeeds. Applies this procedure many times.+pAnyOf :: Parse m s => [m a] -> m [a]+pAnyOf ps = nonEmpty $ catMaybes <$> many' (Just <$> choice' ps |> Nothing <$ skip)++-- | Execute a parser N times.+pReplicate :: Parse m s => Int -> m a -> m [a]+pReplicate 0 _ = succeed []+pReplicate i p | i > 0 = (:) <$> p <*> pReplicate (i-1) p+               | otherwise = fail "Recognize.Parsing.Parse: replicate bounds below zero"++-- | Specialised version of `peek` for `Expr`+peekExpr :: Parse m Math => m Expr+peekExpr = peek >>= getExpr++-- | Specialised version of `peek` for `Equation Expr`+peekEq :: Parse m Math => m (Equation Expr)+peekEq = peek >>= getEq++-- | Parse an expression that has exactly two children+getBinary :: Parse m Math => Expr -> m (Expr, Expr)+getBinary e =+   case getFunction e of+      Just (_, [x, y]) -> return (x,y)+      _ -> empty++-- | Parse an input as an `Equation Expr` whose both sides must satisfy their respective predicates.+satisfyEq :: Parse m Math => (Expr -> Bool) -> (Expr -> Bool) -> m (Equation Expr)+satisfyEq f g = do+  (x :==: y) <- peek >>= getEq+  if f x && g y then skip >> return (x :==: y)+                else empty++-- | Skip an input and return a different value instead+pRewrite :: Parse m s => a -> m a+pRewrite a = skip >> return a++-- | Parses any `Expr`+pAnyExpr :: Parse m Math => m Expr+pAnyExpr = (peek >>= getExpr) <* skip++-- | Parse an `Expr` that is equal to the argument `Expr`+pExpr :: Parse m Math => Expr -> m ()+pExpr e = () <$ pExprWith (\a -> (a, [])) e++-- | Parse an `Expr` that is equal to the argument `Expr`.+--+-- Also takes a function that may be applied to both the argument and input `Expr`.+pExprWith :: Parse m Math => (Expr -> (Expr, [Attribute])) -> Expr -> m (Expr, [Attribute])+pExprWith f x = satisfyWith $ \m ->+    case getExpr m of+      Just y -> do+        let (fx,attr1) = f (toExpr x)+        let (fy,attr2) = f y+        guard $ fx == fy+        return (y, attr1 \\ attr2)+      Nothing -> Nothing++-- | Parse an `Equation` that is equal to the argument `Equation`+pEq :: Parse m Math => Equation Expr -> m ()+pEq e = () <$ pEqWith (\a -> (a, [])) e++-- | Parse an `Equation` that is equal to the argument `Equation`+--+-- Also takes a function that may be applied to both the argument and input `Expr`.+pEqWith :: Parse m Math => (Expr -> (Expr,[Attribute])) -> Equation Expr -> m (Equation Expr,[Attribute])+pEqWith f x = satisfyWith (\m ->+    case getEq m of+      Just y -> do+        let (fxl,_)   = f $ leftHandSide x+            (fxr,_)   = f $ rightHandSide x+            (fyl,ayl) = f $ leftHandSide y+            (fyr,ayr) = f $ rightHandSide y+        guard $ fxl == fyl && fxr == fyr+        return (y,ayl \\ ayr)+      Nothing -> Nothing)++-- | Parse an expression that matches the argument expression modulo commutativity+pExprCom :: Parse m Math => Expr -> m ()+pExprCom e = () <$ pExprWith (\a -> (nfCom a,[])) e++-- | Parse an equation that matches the argument expression modulo commutativity+pEqCom :: Parse m Math => Equation Expr -> m ()+pEqCom e = () <$ pEqWith (\a -> (nfCom a,[])) e++-- | This function is given a list of parsers that must all succeed in the order of the list.+--+-- Input may be skipped as much as necessary. The result of the previous parsing is also available.+pInOrderAll :: Parse m Math => [Maybe (Expr,[r]) -> m (Expr,[r])] -> m (Expr, [r],[Math])+pInOrderAll = rec Nothing 1 []+ where+   rec _ e sk [] = return (e, [], sk)+   rec m _ sk (x:xs) = do+      sk' <- few skip+      (e1, st) <- x m+      (e2, rs, ms) <- rec (Just (e1, st)) e1 (sk ++ sk') xs+      return (e2, st ++ rs, ms)++-- | This function is given a list of parsers that are executed in order of the list.+--+-- Input may be skipped as much as necessary. A parser may fail (none of the remaining input could be parsed) and thus is skipped.+--+-- The result of each previous successful parsing is available.+pInOrder :: (ParseLog m, Parse m Math) => [Maybe (Expr,[r]) -> m (Expr,[r])] -> m (Expr, [r], [Math])+pInOrder = rec Nothing 1 []+ where+   rec _ e sk [] = return (e, [], sk)+   rec m e sk (x:xs) = do+      n <- getInputSize+      pLog $ "I Size: " ++ show n+      choice+         [ do+            pLog "before skip"+            sk' <- return [] <|> (skip >> pLog "skipped" >> return [])+            -- let sk' = []+            -- s <- peek+            -- pLog ("pInOrder: " ++ show s)+            (e',st) <- x m+            pLog "was success"+            (e'',ss,sk'') <- rec (Just (e',st)) e' (sk++sk') xs+            return (e'',st ++ ss,sk'')+         , rec m e sk xs+         ]++-- | Repeatedly execute a parser until we can no longer find any input for a successful parsing.+--+-- Input may be skipped as much as necessary between executions.+--+-- The remaining input is determined by the remaining input after the last successful parsing.+pRepeat :: Parse m Math => m (Expr,[r]) -> m ([Expr],[r],[Math])+pRepeat p = do+  eth <- choice'+    [ do+      sk <- few skip+      (e,r) <- p+      return $ Right (e, r, sk)+    , return $ Left ([],[],[])+    ]++  case eth of+    Left s -> return s+    Right (e,r,sk) -> do+      (e',r',sk') <- pRepeat p+      return (e:e',r++r',sk++sk')
+ src/Recognize/Parsing/Interpretation.hs view
@@ -0,0 +1,505 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Parsing.Interpretation+   ( InterpretationParser, toStep, interpret, addWildcardConstraint+   , pStepEq, (>/<), (>*<), (>-<), (>+<), (>^<)+   , (>>*<<), (>>+<<), (>>/<<), withModulo+   , pNamedStep, inLiberalEquationMode, Interpretation+   , getMatchEnvironment, getWildcard, pStepIneq, pStep+   , clearWildcard, pStepStrongIneq', defaultModulo, squared+   , sum'', sum', initialState+   ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Identity+import Control.Monad.State+import Data.Function+import Data.List+import Domain.Math.Data.MultivariatePolynomial+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Ideas.Common.Id+import Ideas.Common.Rewriting+import Ideas.Common.View+import Ideas.Utils.Uniplate+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Data.Diagnosis+import Recognize.Data.Step+import Recognize.Data.Definition+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Expr.Symbols hiding (wildcard)+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.Parsing.MathParser+import Recognize.Data.MathParserOptions+import Recognize.Parsing.Parser+import Util.Expr+import Util.List+import qualified Data.Map as M++data ExprParseState = ExprParseState+ { getEnvironment :: M.Map String Expr -- ^ The environment contains variables the user defined+ , getMatchEnvironment :: M.Map String Expr -- ^ the match environment contains matches for wildcards+ , getPredicateEnvironment :: M.Map String (Expr -> Bool) -- ^ the predicate environment contains predicates for wildcards+ , getEquality :: Expr -> Expr -> State (M.Map String Expr, M.Map String (Expr -> Bool)) Bool -- ^ The equality function used. We can actually think of this as a unification function due to the wildcards+ , isInLiberalEquationMode :: Bool -- ^ liberal equation mode allows you to parse any equation a = b  as long as b - a is equivalent to what you expect+ , isInLiberalParenthesesMode :: Bool+ , isNormalized :: Expr -> Bool -- ^ a function to determine whether an expression is normalized+ }++initialState :: ExprParseState+initialState =+ ExprParseState+ { getEnvironment = mempty+ , getMatchEnvironment = mempty+ , getPredicateEnvironment = mempty+ , getEquality = moduloToEquality defaultModulo+ , isInLiberalEquationMode = False+ , isInLiberalParenthesesMode = True+ , isNormalized = defaultIsNormalized+ }++-- The interpretation parser is a state monad transformer over a regular parser.+-- It contains an environment for the user to define variables and keeps an equality function+-- that specifies how liberal matching on expressions should be.+type InterpretationParser = ParserT ExprParseState Math Identity++-- we model possible inputs a student might have for a given concept as an interpretation.+-- We can assign attributes to such interpretation (e.g. erroneous, misconception, common, far-fetched)+type Interpretation = [(Expr,[Attribute])]++-- | @interpret e@ represents the correct interpretation of @e@ without any attributes assigned+interpret :: Expr -> Interpretation+interpret e = [(e,[])]++--------------------------------------------------------------------------------+-- Equality+--------------------------------------------------------------------------------++--Parses with the given Equality function.+withEquality :: (Expr -> Expr -> State (M.Map String Expr, M.Map String (Expr -> Bool)) Bool) -> InterpretationParser a -> InterpretationParser a+withEquality e p = do+   oldEq <- state $ \st -> (getEquality st, st { getEquality = e })+   x <- p+   modify $ \st -> st { getEquality = oldEq }+   return x++--Turns a Expr -> Expr function f (called a modulo) into an Equality function.+--What this means is that the Equality function generated will treat two expressions that are equal under the effect of the function f as equal.+moduloToEquality :: (Expr -> Expr) -> Expr -> Expr -> State (M.Map String Expr, M.Map String (Expr -> Bool)) Bool+moduloToEquality f x y = do+   r <- eqComAssoc f x y -- same problem here with normalization of wildcards....+   if r then return r+        else eqComAssoc f (f x) (f y)++--Takes a function Expr -> Expr f and parses with the added condition that two expressions are equal if they are equal under the effect of f.+withModulo :: (Expr -> Expr) -> InterpretationParser a -> InterpretationParser a+withModulo = withEquality . moduloToEquality++--The default modulo function.+defaultModulo :: Expr -> Expr+defaultModulo = restoreWildcards . simplify (multivariatePolynomialViewWith rationalApproxView) . normalizePow . normalizeSqrt . wildcardsToVars+  where normalizeSqrt = transform f+        f (Sym s [Sqrt e, Nat 2]) | isPowerSymbol s = e+        f (Sym s [Sym w [e, Nat 1 :/: Nat 2], Nat 2]) | isPowerSymbol s , isPowerSymbol w = e+        f (Sqrt a :*: Sqrt b) | a == b = a -- werkt nu natuurlijk niet in product view..  (sqrt(2)*3*sqrt(2))+        f e = e+        normalizePow = transform h+        h (Sym s [e, Nat i]) | isPowerSymbol s+                            , i > 0 && i < 5 = foldr1 (.*.) (replicate (fromInteger i) e)+        h e = e++--------------------------------------------------------------------------------+-- Normalization+--------------------------------------------------------------------------------++--The default normailization function. (Notice that this is the only normalization function used in the InterpretationParser as of now.)+defaultIsNormalized :: Expr -> Bool+defaultIsNormalized p = sumEqual (sumList p) (sumList n)+ where+   n = simplify (multivariatePolynomialViewWith rationalView) (nf p)+   sumList (a1 :+: a2) = sumList a1 ++ sumList a2+   sumList (a1 :-: a2) = sumList a1 ++ map Negate (sumList a2)+   sumList a = [a]+   sumEqual (x : xs) ys = sumEqual xs (removeFirst x [] ys)+   sumEqual [] [] = True+   sumEqual [] _ = False+   removeFirst x as (b:bs) | eqNorm x b = as ++ bs+                           | otherwise  = removeFirst x (as++[b]) bs+   removeFirst _ as [] = as+   eqNorm (Sym s1 _) (Sym s2 _) | isWildcardSymbol s1  && isWildcardSymbol s2 = False+   eqNorm (Nat a) (Nat b) = a == b+   eqNorm (Number a) (Number b) = a == b+   eqNorm (Nat a1 :/: Nat a2) (Number b) = fromIntegral a1 / fromIntegral a2 == b+   eqNorm (Number a) (Nat b1 :/: Nat b2) = fromIntegral b1 / fromIntegral b2 == a+   eqNorm (Var a) (Var b) = a == b+   eqNorm (a1 :*: a2) (b1 :*: b2) = (eqNorm a1 b1 && eqNorm a2 b2) || (eqNorm a1 b2 && eqNorm a2 b1)+   eqNorm a@(_ :+: _) b@(_ :+: _) = sumEqual (sumList a) (sumList b)+   eqNorm a@(_ :-: _) b@(_ :-: _) = sumEqual (sumList a) (sumList b)+   eqNorm a@(_ :-: _) b@(_ :+: _) = sumEqual (sumList a) (sumList b)+   eqNorm a@(_ :+: _) b@(_ :-: _) = sumEqual (sumList a) (sumList b)+   eqNorm (a1 :/: a2) (b1 :/: b2) = eqNorm a1 b1 && eqNorm a2 b2+   eqNorm (Sqrt a) (Sqrt b)       = eqNorm a b+   eqNorm (Negate a) (Negate b)   = eqNorm a b+   eqNorm (Sym sa as) (Sym sb bs) | sa == sb+          = as == bs+   eqNorm _ _ = False+++--------------------------------------------------------------------------------+-- Liberal equation mode+--------------------------------------------------------------------------------+-- Liberal equation mode interprets an equation a = b as an expression by subtracting the rhs from the lhs: a - b (=0).+-- This allows to parse a broad set of equations from a single expression (e.g. 7).+inLiberalEquationMode :: InterpretationParser a -> InterpretationParser a+inLiberalEquationMode p = do+   st <- get+   let old = isInLiberalEquationMode st+   put st { isInLiberalEquationMode = True }+   x <- p+   put st { isInLiberalEquationMode = old }+   return x++--------------------------------------------------------------------------------+-- Wildcards+--------------------------------------------------------------------------------+clearWildcard :: String -> InterpretationParser ()+clearWildcard s = modify $ \st ->+   st { getMatchEnvironment = M.delete s (getMatchEnvironment st) }++getWildcard :: String -> InterpretationParser (Maybe Expr)+getWildcard s = gets (M.lookup s . getMatchEnvironment)++setWildcards :: M.Map String Expr -> InterpretationParser ()+setWildcards me = state (\s -> ((), s {getMatchEnvironment = me}))++addWildcardConstraint :: String -> (Expr -> Bool) -> InterpretationParser ()+addWildcardConstraint v p = state (\s -> ((), s {getPredicateEnvironment = M.insert v (p . toExpr) (getPredicateEnvironment s)}))++--------------------------------------------------------------------------------+-- Definitions+--------------------------------------------------------------------------------+addDefinition :: Definition Expr -> InterpretationParser ()+addDefinition (v, x) = state (\e@ExprParseState {getEnvironment = env} -> ((), e { getEnvironment = M.insert v x env }))++filterParenthesis :: String -> String+filterParenthesis = filter (`notElem` " {}()[]")++-----------------------------------------------------+-- Parsing of Interpretations of expressions and equations+-----------------------------------------------------++-- | @toStep p@ parses @p@ and captures @Math@ and returns a @Step@+toStep :: Id -> InterpretationParser [Attribute] -> InterpretationParser Step+toStep i p = pWithMath $ \m -> p >>= \ats -> pure $ smallStep i (m,nub ats)++toBigStep :: InterpretationParser [Step] -> InterpretationParser Step+toBigStep p = do steps <- p+                 case safeHead steps of+                   Nothing -> empty+                   Just s@(Step i (v,_) _) -> if length steps == 1 then return s+                                        else return (bigStep i (v,sort $ nub $ concatMap (\(Step _ (_,ats) _) -> ats) steps) steps)++-- | @pNamedStep n a@ represents an Interpretation that can be named (L = ..), but still requires the concept+-- to be explicitly written down. (e.g. @pNamedStep (interpret (Var "L")) (interpret (3+1)) succeeds on "3+1", "L=3+1", "L=4" but not on "L"+pNamedStep :: Id -> Interpretation -> Interpretation -> InterpretationParser Step+pNamedStep i a xs = pStepEq i a xs+                 |> pStepEq i xs a+                 |> pStep i xs++-- | @pStep a i@ parses interpretation @i@ and assigns attribute @a@ (as identifier)+-- We first try to see if we can match an equation e = e+-- then we try to see if we can match a single expression e+-- otherwise we try to see if we can match an equation * = e, or e = * where * is a wildcard+pStep :: Id -> Interpretation -> InterpretationParser Step+pStep i xs = toBigStep $ many1'+    (   toStep i (pSingleEquation xs xs)+     |> toStep i (snd <$> pSingleExpression xs)+     |> toStep i (matchEquation (interpret $ wildcard "_step") xs)+     |> toStep i (matchEquation xs (interpret $ wildcard "_step"))+    )+  where+    matchEquation as bs = do+      x <- pSingleEquation as bs+      mExpr <- getWildcard "_step"+      clearWildcard "_step"+      case mExpr of+         Just e -> return (PartialMatch e : x)+         _ -> return x++-- | @pStepRel i1 i2 xs ys@ parses an (in)equality @xs@ is assumed to be at most as big as @ys@.+-- if we match on an equality we use @i1@ as step id, otherwise @i2@+pStepRel :: Id -> Id -> Interpretation -> Interpretation -> InterpretationParser Step+pStepRel i1 i2 xs ys = pStepEq i1 xs ys+                    |> pStepWeakIneq i2 xs ys+                    |> pStepStrongIneq i2 xs ys++-- | @pStepEq@ parses a (chained) equation.+pStepEq :: Id -> Interpretation -> Interpretation -> InterpretationParser Step+pStepEq i xs ys = toBigStep $+     (:) <$> toStep i (pSingleEquation xs ys) <*> many' (toStep i (pSingleEquation ys ys))+  |> (:) <$> toStep i (pSingleEquation ys xs) <*> many' (toStep i (pSingleEquation xs xs))++pStepWeakIneq :: Id -> Interpretation -> Interpretation -> InterpretationParser Step+pStepWeakIneq i = stepIneq i pSingleWeakInequation++pStepStrongIneq :: Id -> Interpretation -> Interpretation -> InterpretationParser Step+pStepStrongIneq i = stepIneq i pSingleStrongInequation++pStepStrongIneq' :: Id -> Interpretation -> Interpretation -> InterpretationParser Step+pStepStrongIneq' i = stepIneq i pSingleStrongInequation'++pStepIneq :: Id -> Interpretation -> Interpretation -> InterpretationParser (RelationType, Step)+pStepIneq i xs ys = (,) LessThanOrEqualTo <$> pStepWeakIneq i xs ys+                 |> (,) GreaterThanOrEqualTo <$> pStepWeakIneq i ys xs+                 |> (,) LessThan <$> pStepStrongIneq i xs ys+                 |> (,) GreaterThan <$> pStepStrongIneq i ys xs++-- TODO Hier gaat iets niet goed!    xs == xs < ys == ys |> ys == ys < xs == xs+-- Wat gaat niet goed: Als we relatie x < y willen herkennen+-- we herkennen dan als juist:  x < y+-- dan herkennen we ook x = x' < y' = y+-- we herkennen ook y < x  als incorrect+-- maar we herkennen niet y = y' < x' = x   als incorrect.+-- Komt verder niet echt in data set voor dus voor nu laten zitten.+stepIneq :: Id -> (Interpretation -> Interpretation -> InterpretationParser [Attribute]) -> Interpretation -> Interpretation -> InterpretationParser Step+stepIneq i pSingleIneq xs ys = toBigStep (combine xs ys {- TODO HIER BUG:  |> combine ys xs) -})+  where+   combine :: Interpretation -> Interpretation -> InterpretationParser [Step]+   combine xs ys = do+     as <- many' (toStep i (pSingleEquation xs xs))+     b <- toStep i (pSingleIneq xs ys)+     cs <- many' (toStep i (pSingleEquation ys ys))+     return (as ++ [b] ++ cs)+++pSingleStrongInequation :: Interpretation -> Interpretation -> InterpretationParser [Attribute]+pSingleStrongInequation xs ys = snd <$> (+      pExplicitRel [(LessThan,[],xs,ys)]+   |> pExplicitRel [(GreaterThan,[],ys,xs)])++-- todo: make nicer (Have Interpretation (Relation Expr))+pSingleStrongInequation' :: Interpretation -> Interpretation -> InterpretationParser [Attribute]+pSingleStrongInequation' xs ys =+  snd <$> (+     pExplicitRel [(LessThan,[],xs,ys)]+  |> pExplicitRel [(GreaterThan,[],ys,xs)]+  |> pExplicitRel [(LessThan,[AsymmetricRelation],ys,xs)]+  |> pExplicitRel [(GreaterThan,[AsymmetricRelation],xs,ys)]+  |> pExplicitRel [(LessThanOrEqualTo,[InequalityStrictness],xs,ys)]+  |> pExplicitRel [(GreaterThanOrEqualTo,[InequalityStrictness],ys,xs)]+  |> pExplicitRel [(LessThanOrEqualTo,[InequalityStrictness,AsymmetricRelation],ys,xs)]+  |> pExplicitRel [(GreaterThanOrEqualTo,[InequalityStrictness,AsymmetricRelation],xs,ys)]+  )++pSingleWeakInequation :: Interpretation -> Interpretation -> InterpretationParser [Attribute]+pSingleWeakInequation xs ys = snd <$> (+      pExplicitRel [(LessThanOrEqualTo,[],xs,ys)]+   |> pExplicitRel [(GreaterThanOrEqualTo,[],ys,xs)])++pSingleExpression :: Interpretation -> InterpretationParser (Expr, [Attribute])+pSingleExpression xs = do+   st <- get+   choice'+     [ pExprWithWildcard e ats+       |>+       do d@(_,p) <- pDefinition' e+          addDefinition d+          return (p, [ Normalized | isNormalized st p ] ++ ats)+     | (e,ats) <- xs+     ]++pSingleEquation :: Interpretation -> Interpretation -> InterpretationParser [Attribute]+pSingleEquation a b = snd <$> pExplicitRel [(EqualTo,[],a,b)]++pDefinition' :: Expr -> InterpretationParser (Definition Expr)+pDefinition' x = do+   st <- get+   (d,me) <- satisfyWith (\m ->+      case getEq m of+        Just (d :==: y) -> do+          let (b,(me,_)) = runState ((getEquality st `on` substitute (getEnvironment st)) x y) (getMatchEnvironment st, getPredicateEnvironment st)+          guard b+          case getVariable d of+            Just v -> return ((v, y),me)+            _ -> Nothing+        Nothing -> Nothing)+   setWildcards me+   return d++pExplicitRel :: [(RelationType,[Attribute],Interpretation,Interpretation)] -> InterpretationParser (Relation Expr, [Attribute])+pExplicitRel rs = choice' [ do+   st <- get+   mE <- safePeek+   m <- return $+                  do e <- mE+                     r <- getRelation e+                     guard (relationType r == rT)+                     if isInLiberalEquationMode st && relationType r == EqualTo+                      then+                       do+                        ((_,(me2,_)),as) <- find (fst.fst) $ map (first (flip runState (getMatchEnvironment st,getPredicateEnvironment st) . (getEquality st `on` substitute (getEnvironment st)) (leftHandSide r :-: rightHandSide r))) (xs >-< ys <|> interpret (Negate 1) >*< (xs >-< ys))+                        let me3 = M.map toExpr me2+                        return (r , [ Normalized | checkNormalized st r ] ++ rAts ++ as, me3)+                      else+                       do+                        ((_,(me2,_)),as) <- find (fst.fst) $ map (first (flip runState (getMatchEnvironment st, getPredicateEnvironment st) . (getEquality st `on` substitute (getEnvironment st)) (leftHandSide r))) xs+                        ((_,(me3,_)),bs) <- find (fst.fst) $ map (first (flip runState (me2, getPredicateEnvironment st) . (getEquality st `on` substitute (getEnvironment st)) (rightHandSide r))) ys+                        return (r , [ Normalized | checkNormalized st r ] ++ rAts ++ as ++ bs, me3)+   case m of+    Just (r,ats,me) -> do _ <- skip+                          setWildcards me+                          when (relationType r == EqualTo) (mapM_ addDefinition (match definitionView r))+                          return (r, ats)+    _ -> empty+ | (rT,rAts,xs,ys) <- rs ]+ where checkNormalized st r | nf (rightHandSide r) == nf (leftHandSide r) = isNormalized st (rightHandSide r) || isNormalized st (leftHandSide r)+                            | isFunctionDefinition (leftHandSide r)       = isNormalized st (rightHandSide r)+                            | isFunctionDefinition (rightHandSide r)      = isNormalized st (leftHandSide r)+                            | isVar (leftHandSide r)                      = isNormalized st (rightHandSide r)+                            | isVar (rightHandSide r)                     = isNormalized st (leftHandSide r)+                            | otherwise                                   = isNormalized st (rightHandSide r :-: leftHandSide r)++++pExprWithWildcard :: Expr -> [Attribute] -> InterpretationParser (Expr,[Attribute])+pExprWithWildcard x as = do+   mE <- safePeek+   st <- get+   let m = do e <- mE+              case getResult e of+                 Left _ -> do+                    guard $ isInLiberalParenthesesMode st+                    e' <- safeSingleton (snd $ parseMath mathParserOptions (filterParenthesis (getString e)))+                    x' <- safeSingleton (snd $ parseMath mathParserOptions (filterParenthesis (show x)))+                    x'' <- getExpr x'+                    y <- getExpr e'+                    let stn = (getEquality st `on` substitute (getEnvironment st)) x'' y+                        (b,(me2,_)) = runState stn (getMatchEnvironment st,getPredicateEnvironment st)+                    guard b+                    return (y,me2,NonMatchingParentheses : as)+                 Right y ->+                    let stn = (getEquality st `on` substitute (getEnvironment st)) x y+                        (b,(me2,_)) = runState stn (getMatchEnvironment st,getPredicateEnvironment st)+                    in guard b >> return (y,me2,as)+   case m of+     Just (y,me3,ats) -> do+        _ <- skip+        setWildcards me3+        return (y, [ Normalized | isNormalized st y] ++ ats)+     _ -> empty++pWithMath :: (Math -> InterpretationParser a) -> InterpretationParser a+pWithMath = (peek >>=)++-----------------------------------------------------+-- Common interpretations for expressions and equations+-----------------------------------------------------++-- | @binaryop f x y@ applies binary function @f@ for each interpretation of @x@ and @y@.+binaryOp :: (Expr -> Expr -> Expr) -> Interpretation -> Interpretation -> Interpretation+binaryOp f xs ys = [ (f x y, xa ++ ya)+                 | (x, xa) <- xs+                 , (y, ya) <- ys]++-- | @>+<@ represents the correct interpretation of @+@ regardless of mistakes in the arguments+infixl 5 >+<+(>+<) :: Interpretation -> Interpretation -> Interpretation+(>+<) = binaryOp (+)++-- | @>*<@ represents the correct representation of @*@+infixl 7 >*<+(>*<) :: Interpretation -> Interpretation -> Interpretation+(>*<) = binaryOp (*)++infixl 6 >-<+(>-<) :: Interpretation -> Interpretation -> Interpretation+(>-<) = binaryOp (-)++infixl 7 >/<+(>/<) :: Interpretation -> Interpretation -> Interpretation+(>/<) = binaryOp (/)++infixr 8 >^<+(>^<) :: Interpretation -> Interpretation -> Interpretation+(>^<) = binaryOp (**)++-- | @x >>*<< y@ generates possible interpretations (correct and erroneous) for multiplying an interpretation of x with an interpretation of y,+-- for now we assume the interpretations x and y are monomial or binomial (because specific to Rectangle Area exercise)+infixl 7 >>*<<+(>>*<<) :: Interpretation -> Interpretation -> Interpretation+xs >>*<< ys = xs >*< ys+          <|> concat+              [+                [ (e + to sumView (delete e zs) * y, xa ++ ya ++ [IncorrectDistribution])+                | let zs = from sumView x+                , length zs > 1+                , e <- zs]+                +++                [ (x * to sumView (delete e zs) + e, xa ++ ya ++ [IncorrectDistribution])+                | let zs = from sumView y+                , length zs > 1+                , e <- zs+                ]+                +++                [ (a + to sumView (delete a zs) * to sumView (delete b ws) + b, xa ++ ya ++ [IncorrectDistribution])+                | let zs = from sumView x+                , length zs > 1+                , a <- zs+                , let ws = from sumView y+                , length ws > 1+                , b <- ws+                ]+              | (x, xa) <- xs+              , (y, ya) <- ys+              ]++-- | @x >>/<< y@ generates possible interpretations (correct and erroneous) for division+-- the erroneous interpretation consists of distributing division over multiplication, eg: (a*b/2 <-> a/2*b/2)+infixl 7 >>/<<+(>>/<<) :: Interpretation -> Interpretation -> Interpretation+xs >>/<< ys = xs >/< ys+          <|> [ (to productView (n, [ a / y | a <- zs ]), xa ++ ya ++ [IncorrectDistribution])+              | (x, xa) <- xs+              , (y, ya) <- ys+              , let (n,zs) = from productView x+              , length zs > 1+              ]++-- | @x >>+<< y@ represents the correct and erroneous interpretation of @+@.+infixl 5 >>+<<+(>>+<<) :: Interpretation -> Interpretation -> Interpretation+xs >>+<< ys = xs >+< ys+          <|> xs >*< ys <! OperatorMixedUp timesSymbol plusSymbol++-- | @sum' xs@ represents correct interpretation of summation+sum'  :: [Interpretation] -> Interpretation+sum' [] = []+sum' xs = foldr1 (>+<) xs++-- | @sum'' xs@ represents the correct and incorrect representation of sum+sum'' :: [Interpretation] -> Interpretation+sum'' [] = []+sum'' xs = foldr1 (>>+<<) xs++squared :: Interpretation -> Interpretation+squared square = concat [ [(s ** 2 , ss)+                    {-     ,(s * s, ss)-}+                          ,(4 * s, Misconception Perimeter Area : ss)+                          ]+                        | (s,ss) <- square]
+ src/Recognize/Parsing/MathLexer.hs view
@@ -0,0 +1,314 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the lexing (1st) phase of the assessment pipeline.+-- The only function you should need is `extract`.+-- Note that we don't do true lexing: we don't convert symbols into tokens.+-- Instead, we mostly tend to remove text/symbols and do some conversion.+--+-----------------------------------------------------------------------------++module Recognize.Parsing.MathLexer (extract, useColumns, parseColumns, parseSimple, allowedWords, trim) where++import Control.Applicative                      (empty)+import Control.Arrow+import Control.Monad+import Data.Char+import Data.Either+import Data.List+import Data.Maybe+import Ideas.Utils.Parsing+import Recognize.Data.StringLexerOptions+import Text.Parsec (Parsec)++type MathLexer = Parsec String StringLexerOptions++-- | This is the lexer function.+--+-- It takes some options for string lexing, the string to lex and return a list of lines and a boolean denoting columnization.+extract :: StringLexerOptions -> String -> ([String], Bool)+extract opts txt = +--  (fixParens $ case parseSimple' opts pMathList $ (unlines . removeEnumerations . lines) phase2 of+  (case parseSimple' opts pMathList $ (unlines . removeEnumerations . lines) phase2 of+      Left msg -> error $  "Recognize.MathMathLexer.extract: " ++ txt ++ "\n" ++ msg+      Right xs -> mapMaybe shorten xs, isJust columnized) -- what is the purpose of shorten here+  where+   phase1 = maybe txt (concatMap unlines) columnized+   phase2 = case parseSimple' opts (preParser bRemDashes (replaceXByMultiplication opts)) phase1 of+          (Left _ ) -> phase1+          (Right r) -> r+   bRemDashes = (>3) . length . filter (isPrefixOf "-" . dropWhile (==' ')) . lines $ phase1+   columnized = useColumns opts txt++-- | Attempts to remove or convert certain symbols+preParser :: Bool -> Bool -> MathLexer String+preParser remDashes repAllX = let f = (++) <$> preParse <*> f+                                      <|> [] <$ eof+                              in (++) <$> remFirstDash <*> f+ where+   preParse :: MathLexer String+   preParse =+      try repX+      <|> try remStatement+      <|> try remGraphicalSymbols+      <|> repPercentage+      <|> (if remDashes then remDashess else empty)+      <|> (:[]) <$> anyChar++   -- | Converts x% to x/100+   repPercentage :: MathLexer String+   repPercentage = "/100" <$ char '%'++   repX :: MathLexer String+   repX | repAllX = "*" <$ oneOf "xX"+        | otherwise = (\a b -> a : "*" ++ [b]) <$> (alphaNum <|> char ')') <* tabsOrSpaces <* oneOf "xX" <* tabsOrSpaces <*> (alphaNum <|> char '(')+++   -- | Removes '->','-- >', '--'+   --+   -- Each graphical symbol may have more '-' characters+   remGraphicalSymbols :: MathLexer String+   remGraphicalSymbols = [' '] <$ (+      try (many1 (char '-') <* char '>')+      <|> try (many1 (char '-') <* char ' ' <* char '>')+      <|> (char '-' *> char '-' *> many1 (char '-'))+      )++   -- potentially hazardous for input "a:" or "x:"   when actually divided by something.+   remStatement :: MathLexer String+   remStatement = [] <$+                  ( string "pour"+                <|> string "est"+                <|> try (string "avec")+                <|> string "choici"+                <|> (:[]) <$> oneOf "aAxX"+                  ) <* tabsOrSpaces <* many digit <* tabsOrSpaces <* char ':'+++   tabsOrSpaces :: MathLexer String+   tabsOrSpaces = many (char ' ' <|> char '\t')++   remFirstDash :: MathLexer String+   remFirstDash | remDashes = "" <$ char '-'+                | otherwise = return ""++   remDashess :: MathLexer String+   remDashess = "\n" <$ char '\n' <* tabsOrSpaces <* char '-'++  {-              removeLeadingDash :: String -> String+                  removeLeadingDash r = if length (splitRegex (mkRegex "\n[' ']*-[' ']*") r) > 4+                                        then subRegex (mkRegex "\n[' ']*-[' ']*") r "\n"+                                        else r+  -}++-- | Determines for a given string whether it should be parsed using columns+-- Columns can occur in a horizontal or vertical fashion.+-- Horizontal columns means that several expressions on a single line form one solution+-- Vertical columns means that several expressions directly below another form one solution+useColumns :: StringLexerOptions -> String -> Maybe [[String]]+useColumns opts s |  nHzColumns > 0 -- There must be horizontal columns+             && mostLinesWithColumns -- Sometimes a single line contains columns but the rest do not.+             && maxXDimension >= maxYDimension = Just allHzColumns -- Determine whether horizontal or vertical columns are used+             | not (null allVtColumns) -- There must be horizontal columns+             && mostLinesWithColumns+             && maxYDimension /= 0 = Just allVtColumns+             | otherwise = Nothing+  where allHzColumns = rights $ map (parseSimple' opts parseColumns) ls+        nHzColumns = length allHzColumns+        allVtColumns = transpose allHzColumns+        maxXDimension = maximum $ map length allHzColumns+        maxYDimension = maximum $ map length allVtColumns+        -- removes spaces at the beginning and end of all lines+        ls = map trim $ lines s+        -- remove empty lines, lines containing too much NL+        ls' = filter (\a -> not $ containsSpaces a || a == "") ls+        mostLinesWithColumns = length ls' - nHzColumns < nHzColumns++complete' :: MathLexer a -> MathLexer a+complete' p = spaces *> (p <* eof)++parseSimple' :: StringLexerOptions -> MathLexer a -> String -> Either String a+parseSimple' opts p = left show . runParser (complete' p) opts ""++-- | Determines whether the string contains at least one space+containsSpaces :: String -> Bool+containsSpaces s = isRight $ parseSimple (many1 space) s++-- | drop spaces before and after+trim :: String -> String+trim = dropWhileEnd isSpace . dropWhile isSpace++-- | Parses several expressions on a single line+parseColumns :: MathLexer [String]+parseColumns = parseColumnLine+  where+    -- We separate columns on ; ; and a space. These may contain additional spaces on the left and right+    seps :: MathLexer Char+    seps = oneOf ";:"+    spaceAsSep :: MathLexer Char+    spaceAsSep = space <* many1 space+    sepsWithSpaces :: MathLexer Char+    sepsWithSpaces = spaces *> seps <* spaces+    -- Parses two or more expressions separated by one of the above+    parseColumnLine = (:) <$> allowedWords <*> many1 ((try spaceAsSep <|> sepsWithSpaces) *> allowedWords)++-- | Matches on expressions that may contain spaces. It currently does parse "60 60" as a single expression+allowedWords :: MathLexer String+allowedWords = (:) <$> choice [alphaNum, oneOf syms] <*> many (try $ optional realSpace *> choice [alphaNum, oneOf syms])+    where syms ="+-–*/=,.:()[]#"++-- | Lex a space+realSpace :: MathLexer Char+realSpace = char ' '++-- | remove unwanted characters from the end+shorten :: String -> Maybe String+shorten = fmap reverse . rec . reverse+ where+   rec []  = Nothing+   rec (x:xs)+      | isSpace x = rec xs+      | x `elem` "+*<=>-–/:([{^.," = rec xs+   rec s = Just s++-- | Removes enumerations:+--+-- * 1:) ..+-- * 2:) ..+-- * etc+removeEnumerations :: [String] -> [String]+removeEnumerations = rec 1+ where+   rec :: Integer -> [String] -> [String]+   rec _ [] = []+   rec n (x:xs) =+      case (hasNumber n x, hasNumber 1 x) of+         (Just ys, _) -> ys ++ rec (n+1) xs+         (_, Just ys) -> ys ++ rec 2 xs+         _            -> x : rec n xs++   hasNumber :: Integer -> String -> Maybe [String]+   hasNumber n s+      | show n `isPrefixOf` s =+           case dropWhile isSpace (drop (length (show n)) s) of+              sep:rest | sep `elem` ":)" ->+                 Just (maybeToList (shorten (dropWhile isSpace rest)))+              _ -> Nothing+      | otherwise = Nothing++-- addParens takes a string and adds parentheses (and other brackets) to the front and end to fix mismatches+-- If the brackets already match, the same string is returned+-- The function assumes that fixing is possible. So in "(])", it assumes that the first two characters are matching brackets and it returns "((])"+-- detParens is a helper function that determines which strings are added to the front and end+fixParens :: [String] -> [String]+fixParens = map addParens++addParens :: String -> String+addParens xs = before ++ xs ++ after+              where (before, after) = detParens "" "" xs++detParens :: String -> String -> String -> (String, String)+detParens before after [] = (before, after)+detParens before after (x:xs) | x=='(' = detParens before (')' : after) xs+                              | x=='{' = detParens before ('}' : after) xs+                              | x=='[' = detParens before (']' : after) xs+detParens before [] (x:xs) | x==')'    = detParens ('(' : before) [] xs+                           | x=='}'    = detParens ('{' : before) [] xs+                           | x==']'    = detParens ('[' : before) [] xs+                           | otherwise = detParens before [] xs+detParens before (y:ys) (x:xs) | elem x ")}]" = detParens before ys xs+                               | otherwise = detParens before (y:ys) xs++      +-- | Lexes math symbols+pMathList :: MathLexer [String]+pMathList = catMaybes <$>+  many (Just <$> pMath <|> Nothing <$ pRest)++-- | Used to parse anything other than math symbols+pRest :: MathLexer String+pRest = concat <$> many1 (pWord <|> otherSym)++-- | Anything but a math symbol+otherSym :: MathLexer String+otherSym = do+   notFollowedBy mathFirstSym+   return <$> anyChar++-- | Natural language+pWord :: MathLexer String+pWord = try $ do+   notFollowedBy pVar+   notFollowedBy reservedWords+   many1 (letter <|> oneOf "'") -- removed '-' (also math symbol)++-- | Match a given string to input case insensitive+pCaseInsensitive :: String -> MathLexer String+pCaseInsensitive = foldr op (return [])+ where+   op :: Char -> MathLexer String -> MathLexer String+   op x m = (toLower x :) <$ (char (toUpper x) <|> char (toLower x)) <*> m++-- | Lex variables.+--+-- Lexing is done case insensitive and we take into account variable white listing+pVar :: MathLexer String+pVar = getState >>= \opts ->+           choice [ try (pCaseInsensitive s) | s <- variableWhitelist opts]+           <|>+             try (do x <- letter+                     notFollowedBy (+                      (if x `elem` "ab"+                      then (do z <- letter+                               guard (z `notElem` "ab")+                               return [z])+                      else return <$> letter)+                      <|> string "'"+                      )+                     return [x])++-- | Lex some math+pMath :: MathLexer String+pMath = (\x xs -> x ++ concat xs) <$> mathFirstSym <*> many mathSym++reservedWords :: MathLexer String+reservedWords = try (pCaseInsensitive "sqrt" <|> pCaseInsensitive "root")++mathFirstSym :: MathLexer String+mathFirstSym = number+           <|> reservedWords+           <|> pVar+           <|> return <$> satisfy (`elem` "+-–([{")++mathSym :: MathLexer String+mathSym = number+      <|> reservedWords+      <|> pVar+      <|> (return <$> satisfy (`elem` "+*<=>-–/:()[]{}^% ")) -- hier x aan toevoegen?+      <|> (return ' ' <$ try (do _ <- satisfy (`elem` "\r\n")+                                 notFollowedBy (char '-'))+          )++number :: MathLexer String+number = digitalNumber+     <|> (:[]) <$> specialNumber+     <|> try (do _ <- char '.'+                 ds <- many1 digit+                 notFollowedBy (char '.')+                 return ("0."++ds))++digitalNumber :: MathLexer String+digitalNumber = do+   xs <- many1 digit+   ys <- option "" (try ((:) <$> (char '.' <|> char ',') <*> many1 digit))+   return (xs ++ ys)++specialNumber :: MathLexer Char+specialNumber = oneOf "½¼¾"
+ src/Recognize/Parsing/MathParser.hs view
@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the parsing (2nd) phase of the assessment pipeline.+-- The only function you should need is `parseMath`.+--+-----------------------------------------------------------------------------++module Recognize.Parsing.MathParser +   ( MParser, parseMath, parseSimple', expr+   ) where++import Control.Monad+import Data.Char+import Data.Either+import Data.List+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Domain.Math.Expr.Symbols+import Ideas.Common.Rewriting+import Ideas.Common.View+import Ideas.Utils.Parsing+import Prelude hiding ((^))+import Recognize.Data.Math+import Recognize.Data.MathParserOptions+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Text.Parsec (Parsec)+import Util.String++type MParser = Parsec String MathParserOptions++-- | Parses a string and return a list of `Math` objects together with a boolean denoting the usage of chained equations.+parseMath :: MathParserOptions -> String -> (Bool, [Math])+parseMath opts s =+   case parseSimple' opts (many1 chainedEquations) s of+      Left msg -> (False, [ M s (Left (MathParseError msg)) ])+      Right xs -> let (bs,ys) = unzip xs+                  in (or bs, [ M s (Right x) | x <- concat ys ])++-- | Attempts to parse a set of expressions that form a chained equation (x = y = z = ..)+--+-- If successful, True is returned together with the list of parsed expressions++-- Otherwise, False is returned with an empty list.+chainedEquations :: MParser (Bool, [Expr])+chainedEquations = expr >>= chainedEquations' False++chainedEquations' :: Bool -> Expr -> MParser (Bool, [Expr])+chainedEquations' alreadyChained x = do+     -- decide on the relation type+     rel <- choice [notEqual, equal, lessThanOrEqualTo, lessThan, greaterThanOrEqualTo, greaterThan]+     -- parse a new expression+     y <- expr+     -- parse the rest of the chained equation+     (gotChained, eqs) <- chainedEquations' True (if isVariable x then x else y)+     -- Sometimes people write chained equations where they simplify an expression and then expand it at the same time.+     -- In that case usually the left most symbol is simplified: (5 + 8 = 13 * 3 = 39 + 4 = ..)+     let y_l = fromMaybe y (getMostLeft y)+     let y' = if nf y_l == nf x && not (isVar y_l) then y_l else y++     return (alreadyChained || gotChained, toExpr (makeType rel x y') : eqs)+    <|>+      return (False, [ x | not alreadyChained ])++equal :: MParser RelationType+equal = EqualTo <$ (+      (try (spstring "==" >> return '=') <|> try (spchar '=' <* spaces <* spchar '=') <|> spchar '=') <* spaces+    )++notEqual :: MParser RelationType+notEqual = NotEqualTo <$ (spstring "/=" <|> spstring "=/=") <* spaces++lessThan :: MParser RelationType+lessThan = LessThan <$ spchar '<' <* spaces++lessThanOrEqualTo :: MParser RelationType+lessThanOrEqualTo = LessThanOrEqualTo <$ spstring "<=" <* spaces++greaterThan :: MParser RelationType+greaterThan = GreaterThan <$ spchar '>' <* spaces++greaterThanOrEqualTo :: MParser RelationType+greaterThanOrEqualTo = GreaterThanOrEqualTo <$ spstring ">=" <* spaces++expr :: MParser Expr+expr = buildExpressionParser exprTable (term <* spaces)++term :: MParser Expr+term = foldl1 (*) <$> factor++factor :: MParser [Expr]+factor = do+   n  <- number+   mx <- optionMaybe factor2+   return (n : fromMaybe [] mx)+ <|> factor2++factor2 :: MParser [Expr]+factor2 = do+   xs <- many1 atom+   mn <- optionMaybe number+   return (xs ++ maybeToList mn)++-- | Parse a single expression+--+-- Does not actually parse every atom (numbers and perhaps more) due to legacy reasons and no time to improve.+atom :: MParser Expr+atom = getState >>= \opts ->+  choice+   [ -- Parse a function call: f(x)+     try $ Sym functionCallSymbol <$> (choice (map spchar (fcallChars opts)) *> parens ((number <|> variable <$> var) `sepBy` (spchar ',' <* spaces)))+   , (\x y -> Sym rootSymbol [x,y]) <$ spstring "root" <* spaces <*> expr <* spaces <*> expr+   , variable <$> var+   , parens (spaces *> expr <* spaces)+   , brackets (spaces *> expr <* spaces)+   , braces (spaces *> expr <* spaces)+   ]+  where+    fcallChars opts = ['f', 'g', 'h', 'F', 'G', 'H'] ++ functionCallWhitelist opts++exprTable :: [[Operator Char MathParserOptions Expr]]+exprTable =+   [ -- precedence level 9++     [ Prefix (negate <$ spchar '-' <* spaces)+     , Prefix (id     <$ spchar '+' <* spaces)+     ]+   , [ Prefix (Sqrt <$ spstring "sqrt" <* spaces)+     ]+   , -- precedence level 7+     [ Infix ((^) <$ spchar '^' <* spaces) AssocRight+     ]+     -- precedence level 7+   , [ Infix ((*) <$ spchar '*' <* spaces) AssocLeft+  --   , Infix ((*) <$ spchar 'x' <* spaces) AssocLeft -- now done by preprocessing+    --  , Infix ((*) <$ spchar 'X' <* spaces) AssocLeft+     , Infix ((/) <$ spchar '/' <* spaces) AssocLeft+     , Infix ((/) <$ spchar ':' <* spaces) AssocLeft+     ]+     -- precedence level 6+   , [ Infix ((+) <$ spchar '+' <* spaces) AssocLeft+     , Infix ((-) <$ spchar '-' <* spaces) AssocLeft+     , Infix ((-) <$ spchar '–' <* spaces) AssocLeft  -- this is a different minus sign    ( –- )++     ]+   ]++--------------------------------------------------------------------------+-- Lexing++var :: MParser String+var = getState >>= \opts ->+  if multByConcatenation opts+  then try $ do c <- satisfy isAlpha+                when (c `elem` ("fghFGH" ++ functionCallWhitelist opts)) $ notFollowedBy (spchar '(') -- done by preprocessing+                return [c]+  else many1 letter++parens :: MParser a -> MParser a+parens = between (spchar '(') (spchar ')')++brackets :: MParser a -> MParser a+brackets = between (spchar '[') (spchar ']')++braces :: MParser a -> MParser a+braces = between (spchar '{') (spchar '}')++spchar :: Char -> MParser Char+spchar c+   | c == '/'  = try (char c <* notFollowedBy (char '='))+   | otherwise = char c++spstring :: String -> MParser String+spstring s = try (string s)++number :: MParser Expr+number = digitalNumber+     <|> specialNumber++digitalNumber  :: MParser Expr+digitalNumber = do+   xs <- many1 digit+   m  <- optionMaybe (try ((char '.' <|> char ',') *> many1 digit))+   case m of+      Just ys -> return (toExpr (read (xs ++ "." ++ ys) :: Double))+      Nothing -> return (toExpr (read xs :: Int))++specialNumber :: MParser Expr+specialNumber = (1 :/: 2) <$ string "½"+            <|> (3 :/: 4) <$ string "¾"+            <|> (1 :/: 4) <$ string "¼"++-- todo: parse a² and a³++-- | Parse until eof+complete' :: MParser a -> MParser a+complete' p = spaces *> (p <* eof)++parseSimple' :: MathParserOptions -> MParser a -> String -> Either String a+parseSimple' opts p = +   left show . runParser (complete' p) opts "" . +   (if convertToLowercase opts then strToLower else id)
+ src/Recognize/Parsing/Parse.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts, FunctionalDependencies, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the parser interface. It consists of three type classes: ParseState, Parse and ParseLog.+-- These three type classes expose the parsing primitives necessary to be implemented by any parser.+-- Although both ParseState and ParseLog are optional, Parse is not.+-- +-----------------------------------------------------------------------------++module Recognize.Parsing.Parse where++import Control.Applicative (Alternative, (<|>))+import Control.Monad.State+import Control.Monad.Identity++infixl 3 |>++-- | Interface for the basic parsing primitives+class (Monad m, Alternative m) => Parse m s | m -> s where+  (|>) :: m a -> m a -> m a+  satisfyWith :: (s -> Maybe a) -> m a+  withInputList :: ([s] -> [a]) -> m a+  +  -- input :: m s [s]+  -- lookAhead :: m s a -> m s a++safePeek :: Parse m s => m (Maybe s)+safePeek = withInputList $ \xs -> +   case xs of+      []   -> [Nothing]+      hd:_ -> [Just hd]+  +option :: Parse m s => m a -> m (Maybe a)+option m = Just <$> m <|> return Nothing++satisfy :: Parse m s => (s -> Bool) -> m s+satisfy f = satisfyWith (\s -> if f s then Just s else Nothing)++guardBy :: (MonadState st m, Alternative m) => (st -> Bool) -> m ()+guardBy p = gets p >>= guard++-- | Interface for monads that are capable of logging.+--+class ParseLog m where+  pLog :: String -> m ()++instance ParseLog Identity where+   pLog _ = return ()++instance ParseLog IO where+   pLog = putStrLn
+ src/Recognize/Parsing/Parser.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Simple parser that has options for using logging.+-- Currently used by `Recognize.Parsing.Interpretation`.+--+-----------------------------------------------------------------------------++module Recognize.Parsing.Parser+   ( Parser, runParser+   , ParserT, runParserT+   ) where++import Debug.Trace+import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.State+import Data.Maybe+import Recognize.Parsing.Parse+import Ideas.Utils.Prelude++newtype ParserT st s m a = PT { runParserT :: st -> [s] -> m [(a, st, [s])] }++instance MonadTrans (ParserT st s) where+   lift m = PT $ \st ss -> do+      a <- m+      return [(a, st, ss)]++instance Monad m => Functor (ParserT st s m) where+  fmap f p = return f <*> p++instance Monad m => Applicative (ParserT st s m) where+   pure a  = PT $ \st ss -> return [(a, st, ss)]+   p <*> q = bind ($) p (const q)++instance Monad m => Monad (ParserT st s m) where+   (>>=) = bind (const id)+   fail _ = empty++instance Monad m => Alternative (ParserT st s m) where+   empty   = PT $ \_ _ -> return []+   p <|> q = PT $ \st ss -> do+      xs <- runParserT p st ss+      ys <- runParserT q st ss+      return (xs ++ ys)++instance Monad m =>Parse (ParserT st s m) s where+   p |> q = PT $ \st ss -> do+      xs <- runParserT p st ss+      case xs of+         [] -> runParserT q st ss+         _  -> return xs++   satisfyWith f = PT $ \st ss ->+      case ss of+         y:ys -> return [ (a, st, ys) | a <- maybeToList (f y) ]+         _    -> return []++   withInputList f = PT $ \st ss -> return [ (a, st, ss) | a <- f ss ]++instance Monad m => MonadState st (ParserT st s m) where+   state f = PT $ \st ss ->+      let (a, st2) = f st+      in return [(a, st2, ss)]++instance (Monad m, ParseLog m) => ParseLog (ParserT st s m) where+   pLog = lift . pLog++{-# INLINE bind #-}+bind :: Monad m => (a -> b -> c) -> ParserT st s m a -> (a -> ParserT st s m b) -> ParserT st s m c+bind mk p f = PT $ \st ss -> do+   xs <- runParserT p st ss+   fmap concat $ forM xs $ \(a, st2, ss2) -> do+      ys <- runParserT (f a) st2 ss2+      return [ (mk a b, st3, rest) | (b, st3, rest) <- ys]++------------------------------------------------------------------------------+-- Parser and instances+------------------------------------------------------------------------------++type Parser s = ParserT () s Identity++runParser :: Parser s a -> [s] -> Maybe a+runParser p = fmap fst3 . listToMaybe . runIdentity . runParserT p ()
+ src/Recognize/Preprocessing.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Here we perform some natural language processing by replacing certain words with their math equivalent.+--+-----------------------------------------------------------------------------++module Recognize.Preprocessing where++import Recognize.Data.Solution+import Util.String+import qualified Data.Map as M++mapGerman :: M.Map String String+mapGerman = M.fromList {- fmap (bimap (enclose ' ') (enclose ' '))-}+ [(" mal ","*")+ ,(" durch ","/")+ ,(" plus ","+")+ ,(" hoch ","^")+ ,(" quadrat ","^2")+ ]++preProcess :: Maybe Language -> String -> String+preProcess (Just DE) = applyMap mapGerman+preProcess _ = id++applyMap :: M.Map String String -> String -> String+applyMap m s = foldr (uncurry replace) s (M.toList m)+++enclose :: Char -> String -> String+enclose c s = c : s ++ [c]
+ src/Recognize/Recognizer.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Contains some default recognizer (diagnosis) functions.+-----------------------------------------------------------------------------++module Recognize.Recognizer where++import Recognize.Data.DiagnoseError+import Recognize.Expr.Functions+import Control.Monad.Identity+import Recognize.Data.Math+import Recognize.Parsing.Parser+import Recognize.Parsing.Interpretation+import Recognize.SubExpr.SEParser++-- The default recognizer works on @[Math]@ by using an instance of @Parse m s@+defaultRecognizer :: InterpretationParser a -> [Math] -> Either DiagnoseError a+defaultRecognizer p xs =+   case runIdentity (runParserT p initialState ys) of+      []          -> Left msg+      (a, _, _):_ -> Right a+ where+  (ys, _) = unchainAll xs+  msg | null xs     = Empty+      | otherwise   = Unknown++-- The default recognizer works on @[Math]@ by using an instance of @Parse m s@+seRecognizer :: SEParser a -> [Math] -> Either DiagnoseError a+seRecognizer p xs = maybe (Left msg) Right $ seParse p ys+ where+  (ys, _) = unchainAll xs+  msg | null xs     = Empty+      | otherwise   = Unknown
+ src/Recognize/Strategy/Applications.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module exposes a set of functions for manipulating and parsing expressions using strategies.+-- +-----------------------------------------------------------------------------++module Recognize.Strategy.Applications+   ( normalize, simplify, pSolveLinear+   ) where++import Control.Arrow+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Ideas.Common.Library hiding (simplify)+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Data.Diagnosis+import Recognize.Parsing.Parse+import Recognize.Strategy.Derivation+import Recognize.Strategy.Exercises+import Recognize.Strategy.Recognizer+import Recognize.Expr.Normalform+import Util.Cache++-- | Normalizes (commutativity, associativity, distributivity, etc) an expression. Returns a product of a normalized expression and applied rewrites+normalize :: Expr -> (Expr, [Attribute])+normalize = cached "normalize" $ \e ->+   first nfComAssoc $ fromMaybe (e,[]) $ deriveExprSteps normalizeExercise e++-- | Simplifies an expression. Returns a product of the simplified expression and applied rewrites.+simplify :: Expr -> (Expr, [Attribute])+simplify = cached "simplify" $ \e ->+   first nfComAssoc $ fromMaybe (e,[]) $ deriveExprSteps simplifyExercise e++-- | Given an exercise, find a default derivation for an expression. Returning the derived expression and applied rewrites.+deriveExprSteps :: (Show e, ToAttribute e) => Exercise e -> e -> Maybe (e,[Attribute])+deriveExprSteps ex e = do+  deriv <- defaultDerivation ex e+  attrs <- fromDerivation $ updateSteps (\_ s _ -> fst s) deriv+  let term = lastTerm deriv+  se <- fromContext term+  return (se, attrs)++-- | Parses expressions that solve a linear equation. Returns the steps (containing rewrites) taken.+pSolveLinear :: (ParseLog m, Parse m Math, Relational f) => Maybe (f Expr, Math) -> m (Relation Expr, [Step])+pSolveLinear mfe = pExercise recognizerExercise mrel+  where+    mrel = fmap (first (\fe -> leftHandSide fe .==. rightHandSide fe)) mfe
+ src/Recognize/Strategy/Derivation.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Strategy.Derivation+   ( fromDerivation, fromRule, ToAttribute+   ) where++import           Control.Monad+import           Data.List+import qualified Data.List.NonEmpty       as N+import Domain.Math.Data.Relation+import Domain.Math.Expr                   hiding (sumView)+import Ideas.Common.Context+import Ideas.Common.Derivation+import Ideas.Common.Id+import Ideas.Common.Rule+import Ideas.Common.Traversal.Navigator+import Ideas.Common.View+import Recognize.Data.Attribute+import Recognize.Data.RuleId+import Recognize.Expr.Normalform+import Recognize.Strategy.Views++-- | For each step in a given derivation produce an attribute+fromDerivation :: (ToAttribute e, Show e) => Derivation (Rule (Context e)) (Context e) -> Maybe [Attribute]+fromDerivation = mapM ( \(a,r,b) -> fromRule r a b) . triples++-- | Given a rule, some type that the rule is applied to and the same type that is the result after applying the rule+-- produce an attribute describing this rule.+fromRule :: ToAttribute e => Rule (Context e) -> Context e -> Context e -> Maybe Attribute+fromRule r a b = matchRuleId (show $ getId r) >>= \rid -> toAttribute rid a b++-- | Type class for relating Ideas rules to Attributes for different types.+class ToAttribute e where+  toAttribute :: RuleId -> Context e -> Context e -> Maybe Attribute++instance ToAttribute Expr where+  toAttribute rid ce1 ce2 = do+    let loc = location ce2+    e1 <- navigateTo loc ce1 >>= currentInContext+    e2 <- currentInContext ce2+    case rid of+      Collect_Num -> diffMerge e1 e2 >>= \(a,b) -> return $ ARule Collect_Num a b+      Collect_Var -> diffMerge e1 e2 >>= \(a,b) -> return $ ARule Collect_Var a b+      _ -> return $ ARule rid (e1 N.:| []) e2++instance ToAttribute (Relation Expr) where+  toAttribute rid cre1 cre2 = do+    let loc = location cre2+    re1 <- navigateTo loc cre1 >>= currentInContext+    re2 <- currentInContext cre2+    return $ ARuleR rid re1 re2++-- Works under assumption that merge rule was applied correctly+-- such that+diffMerge :: Expr -> Expr -> Maybe (N.NonEmpty Expr,Expr)+diffMerge e1 e2 = do+  let es1 = nfComAssoc <$> from sumView e1+      es2 = nfComAssoc <$> from sumView e2+      common = es1 `intersect` es2+      diff1 = es1 \\ common+      diff2 = es2 \\ common+  guard (length diff2 <= 1 && length diff1 >= 1)+  case (diff1,diff2) of+    ([],_) -> Nothing+    ([x],[]) -> return (x N.:| common, e2)+    (x:xs,[]) -> return (x N.:| xs, 0)+    (x:xs,y:_) -> return (x N.:| xs, y)
+ src/Recognize/Strategy/Exercises.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Custom exercises used within the AdviseMe code.+--+-----------------------------------------------------------------------------++module Recognize.Strategy.Exercises where++import Domain.Math.CleanUp+import Domain.Math.Data.Relation+import Domain.Math.Equation.Views+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.BuggyRules+import Domain.Math.Polynomial.Views+import Ideas.Common.Library++import Recognize.Strategy.Strategies+import Recognize.Strategy.Views++-- | Exercise used by the strategy recognizer for recognizing linear equations.+-- This exercise uses the `recognizerStrategy` strategy and has two additional characteristics:+--+-- * Expressions are seen as equal up to 1 decimal (1.15 == 1.2)+-- * Relations are equal regardless of the relation type (a < b == a > b)+recognizerExercise :: Exercise (Relation Expr)+recognizerExercise = makeExercise+  { exerciseId    = describe "Evaluate an equation to solved form" $ newId "eval.equation.solvedform"+  , status        = Experimental+  , strategy      = recognizerStrategy+  , prettyPrinter = show+  , navigation    = termNavigator+  , ready         = predicateView relationSolvedForm+  , similarity    = withoutContext (viewEquivalent (traverseView cleanUpACView >>> approxRelView >>> relEqualityView))+  }++-- | Exercise for simplifying expressions+simplifyExercise :: Exercise Expr+simplifyExercise = makeExercise+   { exerciseId   = describe "simplify expression that may contain variables" $+                       newId "algebra.manipulation.polynomial.rational"+   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))+   , ready        = predicateView $ polyViewWith rationalView+   , strategy     = simplifyStrategy+   , navigation   = termNavigator+   }++-- | Exercise for normalizing expressions+normalizeExercise :: Exercise Expr+normalizeExercise = makeExercise+   { exerciseId   = describe "normalize an expressions (includes simplifying fractions)" $+                       newId "algebra.manipulation.polynomial.rational"+   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))+   , ready        = predicateView $ polyViewWith rationalView+   , strategy     = normalizeStrategy+   , navigation   = termNavigator+   , extraRules   = map liftToContext buggyRulesExpr+   }
+ src/Recognize/Strategy/Recognizer.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Strategy.Recognizer (pExercise) where++import Control.Monad+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Ideas.Common.Library hiding (choice)+import Ideas.Service.State+import Recognize.Data.Attribute+import Recognize.Data.Diagnosis  hiding (steps)+import Recognize.Data.Math+import Recognize.Data.Step+import Recognize.Expr.Functions (getVar)+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.Strategy.Derivation+import qualified Ideas.Service.BasicServices as BS++-- | Parses expressions that represent steps in the given exercise.+-- Parsing stops until a relation is found that is considered 'final' (no more steps in the exercise are possible on this expressions)+pExercise :: (Parse m Math, ParseLog m)+                             => Exercise (Relation Expr) -- ^ Input expressions must be steps conforming to this exercise+                             -> Maybe (Relation Expr, Math) -- ^ Optional starting relation+                             -> m (Relation Expr, [Step])+pExercise e mrel = do+  math <- peek+  rel1 <- maybeToParse $ getRelation math+  (i,m) <- case mrel of+    Nothing -> pTerm e (stateTerm $ s rel1)+    Just (rel2, m) -> return (rel2, m)++  pLog ("pExercise: " ++ show (stateTerm (s i)))+  second (initStep m:) <$> pState e (s i) i+ where+  s = emptyState e++-- | Parse a relation that is equivalent to the given relation.+-- Equivalence is determined by the given exercise.+pTerm :: (ParseLog m, Parse m Math) => Exercise (Relation Expr) -> Relation Expr -> m (Relation Expr, Math)+pTerm ex r = do+  m <- peek+  (f :==: _) <- getEq m+  -- f(x) = 7 + 3x = 50+  -- is parsed as f(x) = 7 + 3x and 7 + 3x = 50. We don't need the first expression, so we attempt to remove it+  r' <- if not (isFunctionCall f)+          then pLog ("pTerm: " ++ show m) >> maybeToParse (getRelation m)+          else do+            (_,m2) <- peek2+            pLog (show m ++ " <==> " ++ show m2)+            e2 <- getExpr m+            pLog (show (getVar f) ++ " " ++ show (getVar e2) ++ " " ++ show (getVar f == getVar e2))+            guard (getVar f == getVar e2)+            pLog ("after guard: " ++ show m2)+            maybeToParse (getRelation m2)+  pLog ("New term: " ++ show r')+  let areEq = similarity ex (inContext ex r) (inContext ex r')+  pLog (show r ++ " | " ++ show r' ++ " | " ++ show areEq)+  guard areEq+  _ <- skip+  return (r',m)++-- | Continuously parse relations that match one of the relations obtained by making steps on the argument relation.+--+-- Stops when no more relations match. Allows upto 2 implicit steps to be made (this may be expensive).+pState :: (ParseLog m, Parse m Math) => Exercise (Relation Expr) -> State (Relation Expr) -> Relation Expr -> m (Relation Expr, [Step])+pState e s i = do+  pLog ("pState: " ++ show s)+  choice'+    [ do+      -- Generate all new relations by making at most 3 steps at once.+      let nextSteps = lookAheadStepsBy 3 s+      choice $ flip map nextSteps $ \(si,s') -> do+        pLog (show si)+        -- Parse the relation+        (t,m) <- pTerm e (stateTerm s')+        -- Continue with that term as the current state term+        (t2,steps) <- pState e s' t+        return (t2, mkStep si s m:steps)+    , do+      -- If finished then stop+      pLog ("Is it finished? " ++ show (finished s))+      pLog (show s)+      guard (finished s)+      pLog "Finished"+      return (i,[])+    , do+      -- Possible that the student made a mistake, in which case we would like to skip this relation.+      math <- peek+      next <- maybeToParse (getRelation math)+      let step = Step (newId "") (math,[UnequalRelations i next]) []+      pLog ("skipped: " ++ show math)+      _ <- skip+      let s' = emptyState e next+      second (step:) <$> pState e s' next+    ]++lookAheadStepsBy :: Int -> State (Relation Expr) -> [([BS.StepInfo (Relation Expr)], State (Relation Expr))]+lookAheadStepsBy 0 _ = []+lookAheadStepsBy n s =+  let af = either (const []) id (BS.allfirsts s)+      nextSteps = concatMap (\(si,s') -> map (first (si:)) $ lookAheadStepsBy (n - 1) s') af+  in map (first (:[])) af ++ nextSteps++mkStep :: [BS.StepInfo (Relation Expr)] -> State (Relation Expr) -> Math -> Step+mkStep si state m = Step (newId "Linear") (m,catMaybes attrs) []+    where+      attrs = map (\(x, y, z) -> fromRule x y z) triples+      triples = intermediateValues si state++intermediateValues :: [BS.StepInfo (Relation Expr)] -> State (Relation Expr) -> [(Rule (Context (Relation Expr)), Context (Relation Expr),Context (Relation Expr))]+intermediateValues [] _ = []+intermediateValues ((r,loc,env):si) s =+  case BS.apply r loc env s of+    Left _ -> []+    Right s' -> (r, stateContext s, stateContext s') : intermediateValues si s'++initStep :: Math -> Step+initStep m = Step (newId "Linear") (m, [Label "Initial equation"]) []
+ src/Recognize/Strategy/Rules.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Defines a set of Ideas rules that may be used for rewriting expressions.+--+-----------------------------------------------------------------------------++module Recognize.Strategy.Rules+( liftRule+, removeTimes+, distributeDivision+, mergeNums+, mergeVars) where++import Control.Monad+import Data.List+import Data.Maybe+import Domain.Math.Expr             hiding (sumView)+import Domain.Math.Data.Relation+import Domain.Math.Numeric.Views+import Domain.Math.Polynomial.Rules+import Domain.Math.Simplification   hiding (mergeAlikeSum)+import Ideas.Common.Library         hiding ((.*.))+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Strategy.Views++-- | Lifts any rule that may be applied to an equation to a rule that can be applied to relations+liftRule :: Rule (Equation Expr) -> Rule (Relation Expr)+liftRule r = makeRule (getId r) $ \rel -> do+  let relType = relationType rel+  (a :==: b) <- apply r (leftHandSide rel :==: rightHandSide rel)+  return (makeType relType a b)++-- | Allows a rewrite that attempts to remove multiplications by division+--+-- >>> 2 * 2 + 4 * a = 8+-- >>> 2 + 2 * a = 4+removeTimes :: Rule (Relation Expr)+removeTimes = doAfter (fmap (collectLikeTerms . distributeAll)) $+   describe "remove times" $+   ruleTrans ("linear", "remove-times") $+   inputWith arg timesDivisionRule+ where+  -- Use transList to allow removal of factor from different variables+   arg = transList $ \eq -> do+      xs <- matchM sumView (leftHandSide eq)+      ys <- matchM sumView (rightHandSide eq)+      -- also consider parts without variables+      -- (but at least one participant should have a variable)+      zs <- forM (xs ++ ys) $ \a -> return (hasSomeVar a, a)+      let f (b, e) = do+             (this, _) <- match (timesView >>> first integerView) e+             return (b, this)++          (bs, ns) = unzip (mapMaybe f zs)+      let sns = subsequences ns+      as <- filter (not . null) sns+      return (fromInteger $ foldr1 lcm as)++-- | Rule wrapper over `distributeDivisionT`+distributeDivision :: Rule Expr+distributeDivision = makeRule "distr-division" distributeDivisionT++-- | Collect (natural) numbers+mergeNums :: Rule Expr+mergeNums = describe "merge numbers (including naturals)" $+   ruleMaybe ("linear", "merge.num") $ \old -> do+      let new  = build sumView $ mergeAlikeSum (\e -> isNat e || isNumber e) (from sumView old)+      guard (nfComAssoc old /= nfComAssoc new)+      return new++-- | Collect variables+mergeVars :: Rule Expr+mergeVars = describe "merge variables" $+   ruleMaybe ("linear", "merge.var") $ \old -> do+      let new  = build sumView $ mergeAlikeSum isVar (from sumView old)+          f    = maybe 0 length . match sumView+      guard (f old > f new)+      return new++mergeAlikeSum :: (Expr -> Bool) -> [Expr] -> [Expr]+mergeAlikeSum p xs = rec [ (pm 1 x, x) | x <- xs ]+ where+   rec [] = []+   rec (((r, a), e):ys) = new:rec rest+    where+      (js, rest) = partition (\((_,a2),_) -> a2 == a && p a) ys+      rs  = r:map (fst . fst) js+      new | null js   = e+          | otherwise = build rationalView (toRational $ sum rs) .*. a++pm :: Double -> Expr -> (Double, Expr)+pm r (e1 :*: e2) = case (match doubleView e1, match doubleView e2) of+                        (Just r1, _) -> pm (r*r1) e2+                        (_, Just r1) -> pm (r*r1) e1+                        _           -> (r, e1 .*. e2)+pm r (Negate e) = pm (negate r) e+pm r e = case match doubleView e of+            Just r1 -> (r*r1, Nat 1)+            Nothing -> (r, e)++timesDivisionRule :: Functor f => ParamTrans Expr (f Expr)+timesDivisionRule = parameter1 factorRef $ \a -> unlessZero a . fmap (\b -> b :*: (1 :/: a))++unlessZero :: Expr -> a -> Maybe a+unlessZero e a = do+   r <- matchM rationalView e+   guard (r /= 0)+   return a++factorRef, termRef :: Ref Expr+factorRef = makeRef "factor"+termRef   = makeRef "term"++-- Only used for cleaning up+distributeAll :: Expr -> Expr+distributeAll expr =+   case expr of+      e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1)+                       bs = fromMaybe [e2] (match sumView e2)+                   in build sumView [ a .*. b | a <- as, b <- bs ]+      _ -> expr
+ src/Recognize/Strategy/Strategies.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines a set of strategies used within the AdviseMe code.+-- Each strategy is specifically tuned for the exercises wherein they are used.+-- Any changes should be followed by testing the exercises.+-- To generate attributes for newly added rules you have to modify "RuleId"+-- +-----------------------------------------------------------------------------++module Recognize.Strategy.Strategies where++import Control.Monad+import Domain.Math.Data.Relation+import Domain.Math.Equation.CoverUpRules  hiding (coverUpPlus)+import Domain.Math.Expr+import Domain.Math.Numeric.Rules+import Domain.Math.Numeric.Views (rationalView, integerNF)+import Domain.Math.Polynomial.Balance+import Domain.Math.Polynomial.RationalRules (cancelTermsDiv)+import Domain.Math.Polynomial.Rules+import Domain.Math.Power.Rules+import Ideas.Common.Library+import Ideas.Common.Strategy.Legacy+import Prelude                              hiding ((<*>))+import Recognize.Strategy.Rules+import Recognize.Strategy.Views++-- | Strategy used by the strategy recognizer to recognize rewrites of linear equations+recognizerStrategy :: IsTerm a => LabeledStrategy (Context a)+recognizerStrategy = label "recognizer strategy" $+  repeat1 $+    use varToLeft+    <|> coverUpPlus+    <|> use coverUpTimesPositive+    <|> use (liftRule conRightMinus)+    <|> use removeTimes+    <|> fractionStrategy++-- | Strategy used for simplifying expressions+simplifyStrategy :: LabeledStrategy (Context Expr)+simplifyStrategy = label "simplify" $ repeatS (+  rules (cancelTermsDiv : map use [ calcTimesWith "rational" rationalRelaxedForm+                                  , calcPower+                                  , simplerFraction+                                  ])+  |> rules (map use [mergeNums, mergeVars])+  |> rules (map use [distributeTimes, distributeDivision]))+  where+    rules rs = somewhere $ alternatives rs++-- | Strategy used for normalizing expressions (equality modulo fraction simplification, distribution and double negation)+normalizeStrategy :: LabeledStrategy (Context Expr)+normalizeStrategy = label "normalize" $+  repeatS $ somewhere $ alternatives $ map use+      [ simplerFraction, distributeTimes, doubleNegate ]++-- | Strategy used for simplifying of expressions containing fractionals+fractionStrategy :: IsTerm a => Strategy (Context a)+fractionStrategy = many1 $+      somewhere+         (  use (calcPlusWith     "integer" integerNF)+        <|> use (calcMinusWith    "integer" integerNF)+        <|> use (calcTimesWith    "integer" integerNF) -- not needed?+        -- <|> use (calcDivisionWith "integer" integerNF)  -- not needed?+         ) |>+      somewhere+         (use fractionTimesCancelDenNom <|> use fractionTimesCancelNomDen) |>+      somewhere+         (  use doubleNegate <|> use negateZero <|> use divisionDenominator+        <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator+         ) |>+      somewhere (use fractionPlusScale) |>+      somewhere (use simplerFraction)++-------------------------+-- copied from IneqExercises++-- helper strategy (todo: fix needed, because the original rules do not+-- work on relations)+coverUpPlus :: IsTerm a => Strategy (Context a)+coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps)+ where+   coverUps :: [ConfigCoverUp -> Rule (Relation Expr)]+   coverUps =+      [ coverUpBinaryRule "plus" (commOp . isPlus) (-)+      , coverUpBinaryRule "minus-left" isMinus (+)+      , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))+      ]++coverUpTimesPositive :: Rule (Relation Expr)+coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp+ where+   m expr = do+      (a, b) <- matchM timesView expr+      r <- matchM rationalView a+      guard (r>0)+      return (a, b)
+ src/Recognize/Strategy/Views.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.Strategy.Views where++import Control.Monad++import Domain.Math.Expr+import Domain.Math.Data.DecimalFraction   as DF+import Domain.Math.Data.Relation+import Domain.Math.Numeric.Views+import Domain.Math.Safe+import Ideas.Common.Library++import Recognize.Expr.Normalform++-- | Copy from "Domain.Math.Numeric.Views".+-- Added a case for Numbers.+rationalRelaxedForm :: View Expr Rational+rationalRelaxedForm = "num.rational-relaxed" @> makeView (optionNegate f) fromRational+ where+   f (Number d) = return $ fromRational $ toRational $ DF.fromDouble d+   f (e1 :/: e2) = do+      a <- match integerNF e1+      b <- match integerNF e2+      safeDiv (fromInteger a) (fromInteger b)+   f (Nat n) = Just (fromInteger n)+   f _       = Nothing++optionNegate :: (Eq a,Num a) => (Expr -> Maybe a) -> Expr -> Maybe a+optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b)+optionNegate f a          = f a++-- | View that rounds expressions to 1 decimal+approxRelView :: Functor f => View (f Expr) (f Expr)+approxRelView = makeView f g+  where+    f rel = return $ fmap (nf4 1) rel+    g = id++-- | Views all relation types as an equality relation+relEqualityView :: View (Relation Expr) (Relation Expr)+relEqualityView = makeView f g+  where+    f rel = return $ leftHandSide rel .==. rightHandSide rel+    g = id++-- | Copy from "Domain.Math.Expr.Views"+-- This version does not throw away 0's+sumView :: Isomorphism Expr [Expr]+sumView = describe "View an expression as the sum of a list of elements, \+   \taking into account associativity of plus, its unit element zero, and \+   \inverse (both unary negation, and binary subtraction)." $+   "math.sum" @> sumEP+ where+   sumEP = (($ []) . f False) <-> foldl (.+.) 0++   f n (a :+: b)  = f n a . f n b+   f n (a :-: b)  = f n a . f (not n) b+   f n (Negate a) = f (not n) a+   f n e          = if n then (neg e:) else (e:)
+ src/Recognize/SubExpr/Compare.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines comparison functions used in the subexpression recognizer.+--+-----------------------------------------------------------------------------++module Recognize.SubExpr.Compare+   ( pCompareBySimplify, pCompareByNormalize,+     pCompare, pSubstituteVars+   ) where++import           Control.Monad+import           Data.List                as L+import qualified Data.Map                 as M+import           Data.Maybe+import Domain.Math.Expr+import Ideas.Common.Library               hiding (option, simplify)+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Expr.Functions         as F+import Recognize.Expr.Normalform+import Recognize.Parsing.Parse+import Recognize.Parsing.Derived+import Recognize.Strategy.Applications+import qualified Recognize.SubExpr.Functions as SF+import Recognize.SubExpr.SEParser+import Util.Cache++-- | Simplifies both expressions using the strategy module and then compares them.+--+-- We return (simplified expression #1, simplified expression #2, rewrites #1 - rewrites #2)+pCompareBySimplify :: Expr -> Expr -> SEParser (Expr, Expr, [Attribute])+pCompareBySimplify m e = do+  (sm,attr) <- pSimplify (nfComAssoc m)+  (se,attrs2) <- pSimplify (nfComAssoc e)+  _ <- gets precision+  b <- pCompareWith (nfComAssoc . nf4 1) sm se+  pLog ("pCompareBySimplify: " ++ show (m,sm,attr) ++ " " ++ show (e,se,attrs2) ++ " " ++ show b)+  guard b+  return (sm, se, attr L.\\ attrs2)++-- | Simplifies a single expression. Returns its simplified form and the used rewrites+pSimplify :: Expr -> SEParser (Expr, [Attribute])+pSimplify e = do+   -- Rewrite rules don't work on our custom vars. Using underSubst+   -- we substitute them with normal vars, rewrite the expression, and then undo the substitution+   (nfe, attr) <- maybeToParse $ SF.underSubst simplify $ SF.cleanExpr e+   pLog ("simplified: " ++ show nfe ++ " " ++ show attr)+   -- Substitute the custom vars with their corresponding values+   cnfe <- SF.cleanExpr <$> pSubstituteVars nfe+   return (cnfe, attr)++-- | Normalizes both expressions and compares them for equality.+--+-- Normalizing here entails sorting on commutativity and associativity, simplifying fractions and applying distributivity.+--+-- We return the first expression and rewrites (simpler fractions, distribution) of the first expression minus the rewrites of the second expression.+pCompareByNormalize :: Expr -> Expr -> SEParser (Expr, [Attribute])+pCompareByNormalize e1 e2 = do+  pLog $ "pCompareByNormalize " ++ show e1 ++ " " ++ show e2+  (ne1,attr1) <- pNormalize e1+  (ne2,attr2) <- pNormalize e2+  pLog ("Normalized: " ++ show ne1)+  pLog ("Normalized: " ++ show ne2)+  b <- pCompare ne1 ne2+  pLog $ "N: " ++ show ne1 ++ " | " ++ show ne2 ++ " " ++ show b+  guard b+  pLog "Normalize equal"+  return (e1, attr1 L.\\ attr2)++pNormalize :: Expr -> SEParser (Expr, [Attribute])+pNormalize e =+   maybeToParse (cachedNormalize e)++cachedNormalize :: Expr -> Maybe (Expr, [Attribute])+cachedNormalize = cached "cachedNormalize" $ \e -> do+   (nfe, attr) <- SF.underSubst normalize e+   return (nfComAssoc (SF.cleanExpr nfe), attr)++-- | Compare two expressions+--+-- Takes into account subexpression variables and magic types.+pCompare :: Expr -> Expr -> SEParser Bool+pCompare e1 e2 = do+  pLog ("pCompare: " ++ show e1 ++ " " ++ show e2)+  b <- pCompareWith id e1 e2+  pLog (show b)+  return b++pCompareWith :: (Expr -> Expr) -> Expr -> Expr -> SEParser Bool+pCompareWith f m e = isJust <$> option (pCompareExpr f (f $ SF.cleanExpr m) (f $ SF.cleanExpr e))++pCompareExpr :: (Expr -> Expr) -> Expr -> Expr -> SEParser ()+pCompareExpr _ (Nat n1) (Nat n2)       = guard $ n1 == n2+pCompareExpr _ (Var x) (Var y)         = guard $ x == y+pCompareExpr _ (Number n1) (Number n2) = guard $ n1 == n2+pCompareExpr f e1 e2+  | (SF.isMagicNat e1 && isNat e2) || (isNat e1 && SF.isMagicNat e2)     = return ()+  | (SF.isMagicNumber e1 && isNumber e2) || (isNumber e1 && SF.isMagicNumber e2) = return ()+  | (SF.isMagicVar e1 && F.isVar e2) || (F.isVar e1 && SF.isMagicVar e2) = return ()+  | SF.isVar e1 = subAndCompare e1 e2+  | SF.isVar e2 = subAndCompare e2 e1+  | isJust (isTimes e1)  = pCompareWithFunction (\e -> Just (timesSymbol,  snd $ from productView e)) f e1 e2+  | isJust (isDivide e1) = pCompareWithFunction (\e -> Just (divideSymbol, snd $ from productView e)) f e1 e2+  | isJust (isPlus e1)   = pCompareWithFunction (\e -> Just (plusSymbol,  from sumView e)) f e1 e2+  | isJust (isMinus e1)  = pCompareWithFunction (\e -> Just (minusSymbol, from sumView e)) f e1 e2+  | otherwise = pCompareWithFunction getFunction f e1 e2+  where+    subAndCompare :: Expr -> Expr -> SEParser ()+    subAndCompare e1 e2 = do+      e1' <- pSubstituteVars e1+      pCompareExpr f (f e1') e2+      -- Happens only if f e1' was equal to e2+      k <- getVarKey e1+      pUpdateVars k e2++-- Limited in the sense that only one (sub)expression may contain a magic natural number of variable+pCompareWithFunction :: (Expr -> Maybe (Symbol, [Expr])) -> (Expr -> Expr) -> Expr -> Expr -> SEParser ()+pCompareWithFunction fun f e1 e2 = do+  pLog ("pCompareExpr: " ++ show e1 ++ " " ++ show e2)+  (s1,xs) <- maybeToParse $ fun e1+  (s2,ys) <- maybeToParse $ fun e2+  let common = xs `intersect` ys+  let (diffX, diffY) = (xs \\ common, ys \\ common)+  guard (s1 == s2)+  let xIsMagic = all (\x -> SF.hasMagicNat x || SF.hasMagicNumber x || SF.hasMagicVar x || SF.hasVar x) diffX+  let yIsMagic = all (\x -> SF.hasMagicNat x || SF.hasMagicNumber x || SF.hasMagicVar x || SF.hasVar x) diffY+  -- Only difference is a magic natural number, so assume it is identity+  pLog ("P: " ++ show common)+  pLog ("P: " ++ show diffX)+  pLog ("P: " ++ show diffY)+  if length diffX == length diffY && (xIsMagic || yIsMagic)+    then mapM_ (uncurry (pCompareExpr f)) (zip diffX diffY)+  -- No difference, hence these must be equal+    else do+      guard $ null diffX && null diffY+      return ()++-- | Map all subexpression variables to the values they refer to+pSubstituteVars :: Expr -> SEParser Expr+pSubstituteVars e = do+  dic <- gets usedVariables+  maybeToParse $ SF.substituteAllIf SF.isVar dic e++-- | Update a subexpression variable with a new value+pUpdateVars :: String -> Expr -> SEParser ()+pUpdateVars k v = modify $ \st ->+   st { usedVariables = M.update (const $ Just v) k (usedVariables st) }
+ src/Recognize/SubExpr/Functions.hs view
@@ -0,0 +1,337 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines commonly used functions within the subexpression recognizer.+--+-----------------------------------------------------------------------------++module Recognize.SubExpr.Functions+   ( -- * Functions on Symbols+     isBuggySymbol, isBuggy, isOrSymbol, isOr, isAndSymbol, isAnd, isVarSymbol+   , isVar, hasVar, isLtSymbol, isLt, isMatchSymbol, isMatch, isMatched+   , hasMatch, extractMatched, getMatched, subMatched, isMagicVarSymbol+   , isMagicVar, hasMagicVar, isMagicNatSymbol, isMagicNat, hasMagicNat+   , isMagicNumberSymbol, isMagicNumber, hasMagicNumber+   , isLabelSymbol, isLabel, isStopSymbol, isStop+   , isSimSymbol, isSim, isSimplified, isNoSimSymbol, isNoSim, isSubSymbol+   , isSub, substituteAllIf, hasSub+     -- * Auxillary functions+   , cleanExpr, underSubst, subExprsCombs, alternativesExpr, isSubExprOf+   ) where++import Control.Arrow+import Control.Monad+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Tuple+import Data.Monoid ((<>))+import Domain.Math.Expr.Data+import Ideas.Common.Rewriting hiding (hasVar)+import Recognize.Data.Attribute+import Recognize.Expr.Normalform+import Recognize.SubExpr.Symbols++isBuggySymbol :: Symbol -> Bool+isBuggySymbol  = (== buggySymbol)++isBuggy :: Expr -> Bool+isBuggy (Sym s [_,_]) = isBuggySymbol s+isBuggy _ = False++isOrSymbol :: Symbol -> Bool+isOrSymbol = (== orSymbol)++isOr :: Expr -> Bool+isOr (Sym s [_,_]) = isOrSymbol s++isAndSymbol :: Symbol -> Bool+isAndSymbol = (== andSymbol)++isAnd :: Expr -> Bool+isAnd (Sym s [_,_]) = isAndSymbol s+isAnd _ = False++isVarSymbol :: Symbol -> Bool+isVarSymbol = (== varSymbol)++isVar :: Expr -> Bool+isVar (Sym s [Var _]) = isVarSymbol s+isVar _ = False++hasVar :: Expr -> Bool+hasVar e = case getFunction e of+  Nothing -> False+  Just (s,xs) -> isVarSymbol s || any hasVar xs++substituteIf :: (Expr -> Bool) -> M.Map String Expr -> Expr -> Maybe Expr+substituteIf p dic e@(Sym s [Var v])+  | isVarSymbol s && p e = M.lookup v dic+  | otherwise = Just e+substituteIf p dic e@(Var v)+  | p e = M.lookup v dic+  | otherwise = Just e+substituteIf _ _ e = Just e++substituteAllIf :: (Expr -> Bool) -> M.Map String Expr -> Expr -> Maybe Expr+substituteAllIf p dic e = case getFunction e of+  Nothing -> substituteIf p dic e+  Just (s,[Var _])+    | isVarSymbol s -> substituteIf p dic e+    | otherwise     -> Just e+  Just (s,xs) -> do+    xs' <- mapM (substituteAllIf p dic) xs+    return $ function s xs'++-- | Builds a dictionary mapping variable strings to values+-- these values are calculated by applying a function to one of those strings+mkVarMap :: Expr -> M.Map String String+mkVarMap e = case getFunction e of+  Nothing -> M.empty+  Just (_,[Var s]) -> M.singleton s s+  Just (_,xs) -> foldr (\a dic -> mkVarMap a <> dic) M.empty xs++isLtSymbol :: Symbol -> Bool+isLtSymbol = (== ltSymbol)++isLt :: Expr -> Bool+isLt (Sym s _) = isLtSymbol s+isLt _ = False++isMatchSymbol :: Symbol -> Bool+isMatchSymbol = (== matchSymbol)++isMatch :: Expr -> Bool+isMatch (Sym s [_]) = isMatchSymbol s+isMatch _ = False++isMatched :: Expr -> Bool+isMatched e = case getFunction e of+  Just (s,[x]) -> isMatchSymbol s || (isNoSimSymbol s && isMatched x)+  Just (s,[x,y]) -> (isAndSymbol s && isMatched x && isMatched y)+    || (isOrSymbol s && (isMatched x || isMatched y))+    || (isLabelSymbol s && isMatched y)+  Just (s,[_,_,z])+    | isLabelSymbol s -> isMatched z+  _ -> False++-- | Does this expression have a matched subexpression?+hasMatch :: Expr -> Bool+hasMatch e = case getFunction e of+  Nothing -> False+  Just (s,xs)+    | isMatchSymbol s -> True+    | otherwise -> any hasMatch xs++-- | If this expression has been matched, then extracted the matched expression+extractMatched :: Expr -> Expr+extractMatched e@(Sym s [x])+  | isMatchSymbol s = x+  | otherwise = e+extractMatched e = e++getMatched :: Expr -> Maybe Expr+getMatched e = case getFunction e of+  Nothing -> Nothing+  Just (s,[x])+    | isMatchSymbol s -> Just x+    | otherwise -> getMatched x+  Just (s,[x,y])+    | isLabelSymbol s -> getMatched y+    | isOrSymbol s -> msum $ map getMatched [x,y]+    | otherwise -> do+      x' <- getMatched x+      y' <- getMatched y+      return $ binary s x' y'+  Just (s,[_,_,z])+    | isLabelSymbol s -> getMatched z+  Just (s,xs) -> do+      xs' <- mapM getMatched xs+      return $ function s xs'++-- | Substitue any matching with its matched expression+subMatched :: Expr -> Expr+subMatched e = case getFunction e of+  Nothing -> e+  Just (s,[x])+    | isMatchSymbol s -> x+    | otherwise -> unary s $ subMatched x+  Just (s,xs) -> function s $ map subMatched xs++-- Matches to any variable+isMagicVarSymbol :: Symbol -> Bool+isMagicVarSymbol = (== magicVarSymbol)++isMagicVar :: Expr -> Bool+isMagicVar (Sym s _) = isMagicVarSymbol s+isMagicVar _ = False++hasMagicVar :: Expr -> Bool+hasMagicVar e = case getFunction e of+  Nothing -> False+  Just (s,xs) -> isMagicVarSymbol s || any isMagicVar xs || any hasMagicVar xs++-- Matches to any natural number+isMagicNatSymbol :: Symbol -> Bool+isMagicNatSymbol = (== magicNatSymbol)++isMagicNat :: Expr -> Bool+isMagicNat (Sym s []) = isMagicNatSymbol s+isMagicNat _ = False++hasMagicNat :: Expr -> Bool+hasMagicNat e = case getFunction e of+  Nothing -> False+  Just (s,xs) -> isMagicNatSymbol s || any isMagicNat xs || any hasMagicNat xs++-- Matches to any natural number+isMagicNumberSymbol :: Symbol -> Bool+isMagicNumberSymbol = (== magicNumberSymbol)++isMagicNumber :: Expr -> Bool+isMagicNumber (Sym s []) = isMagicNumberSymbol s+isMagicNumber _ = False++hasMagicNumber :: Expr -> Bool+hasMagicNumber e = case getFunction e of+  Nothing -> False+  Just (s,xs) -> isMagicNumberSymbol s || any isMagicNumber xs || any hasMagicNumber xs++isLabelSymbol :: Symbol -> Bool+isLabelSymbol = (== labelSymbol)++isLabel :: Expr -> Bool+isLabel (Sym s [_,_]) = isLabelSymbol s+isLabel (Sym s [_,_,_]) = isLabelSymbol s+isLabel _ = False++isStopSymbol :: Symbol -> Bool+isStopSymbol = (== stopSymbol)++isStop :: Expr -> Bool+isStop (Sym s [_]) = isStopSymbol s+isStop _ = False++isSimSymbol :: Symbol -> Bool+isSimSymbol = (== simSymbol)++isSim :: Expr -> Bool+isSim (Sym s [_]) = isSimSymbol s+isSim _ = False++isSimplified :: Expr -> Bool+isSimplified e = cleanExpr e == subMatched e && nf e == e++isNoSimSymbol :: Symbol -> Bool+isNoSimSymbol = (== noSimSymbol)++isNoSim :: Expr -> Bool+isNoSim (Sym s [_]) = isNoSimSymbol s+isNoSim _ = False++isSubSymbol :: Symbol -> Bool+isSubSymbol = (== subSymbol)++isSub :: Expr -> Bool+isSub (Sym s [_]) = isSubSymbol s+isSub _ = False++hasSub :: Expr -> Bool+hasSub e = case getFunction e of+  Nothing -> False+  Just (s,xs) -> isSubSymbol s || any hasSub xs++-- | Remove all custom symbols from the expression+-- Useful/necessary for comandisons.+-- Note that it is not possible to remove all symbols (@and@,or,magicNat,magicVar)+cleanExpr :: Expr -> Expr+cleanExpr e = case getFunction e of+  Nothing -> e+  Just (s,[x])+    | isMatchSymbol s -> cleanExpr x+    | isSimSymbol s -> cleanExpr x+    | isNoSimSymbol s -> cleanExpr x+    | isSubSymbol s -> cleanExpr x+    | isStopSymbol s -> cleanExpr x+    | otherwise -> unary s (cleanExpr x)+  Just (s,[x,y])+    | isLabelSymbol s -> cleanExpr y+    | isAndSymbol s -> cleanExpr x <&> cleanExpr y+    | isOrSymbol s -> cleanExpr x <?> cleanExpr y+    | otherwise -> binary s (cleanExpr x) (cleanExpr y)+  Just (s,[_,_,z])+    | isLabelSymbol s -> cleanExpr z+  Just (s,xs) -> function s (map cleanExpr xs)++-- | Substitutes all special vars with a unique regular Var+-- then applies some function after which the substitution is reversed+underSubst :: (Expr -> (Expr,[Attribute])) -> Expr -> Maybe (Expr, [Attribute])+underSubst f e = do+  let dic = mkVarMap e+  -- M.Map String Expr, actually just M.Map String (Var v)+  let dicU = snd $ M.mapAccum (\acc _ -> (acc+1, Var $ "$$$" ++ show acc)) 0 dic+  eU <- substituteAllIf isVar dicU e+  -- M.Map String String, this is partial but we know that dicU only contains Vars+  let dicU' = M.map (\(Var v) -> v) dicU+  -- M.Map String String+  dicUInverse <- invert dicU'+  -- M.Map String Expr, actually just M.Map String (Sym varSymbol [Var v])+  let dicUInverse' = M.map var dicUInverse+  -- Now we have a simplified form, but we must still replace every var with the expressions+  -- that they refer to.+  let (fe, attr) = f eU+  -- Only substitute a variable if it is present in the dicUInverse' Map, since there might be+  -- other variables already present in the expression+  fe' <- substituteAllIf (\e -> isVariable e &&+    case e of+      Var v -> isJust $ M.lookup v dicUInverse') dicUInverse' fe+  -- TODO: Added attributes now contain the substitute value introduced here instead of the corresponding subexpression variable+  return (fe',attr)++-- | Compute all possible combinations for a list of expressions+subExprsCombs :: [Expr] -> [([Expr],[Attribute])]+subExprsCombs [] = [([],[])]+subExprsCombs (x:xs) =+  let xs' = subExprsCombs xs+  in concatMap (\(e, rw) -> map ((:) e *** (++) rw) xs') (alternativesExpr x)++alternativesExpr :: Expr -> [(Expr, [Attribute])]+alternativesExpr e = case getFunction e of+  Nothing -> [(e,[])]+  Just (s,[x])+    | isSimSymbol s -> [(nf x,[])]+    | otherwise -> first (unary s) <$> alternativesExpr x++  Just (s,[x,y])+    | isBuggySymbol s -> (second (CommonMistake:) <$> alternativesExpr y) ++ alternativesExpr x+    | isOrSymbol s || isAndSymbol s -> alternativesExpr x ++ alternativesExpr y+  Just (s,xs) -> map (first (function s)) $ nary xs+  _ -> error (show e)+  where+    nary :: [Expr] -> [([Expr],[Attribute])]+    nary [] = [([],[])]+    nary (x:xs) = do+      (xe,xa) <- alternativesExpr x+      (xes,xas) <- nary xs+      return (xe:xes,xa++xas)++++isSubExprOf :: Expr -> Expr -> Bool+isSubExprOf x e = x == e || (case getFunction e of+  Nothing -> False+  Just (s,xs) -> any (isSubExprOf x) xs)++invert :: Ord v => M.Map k v -> Maybe (M.Map v k)+invert m = do+  let kvs = M.toList m+  let vs = map snd kvs+  guard (length (nub vs) == length vs)+  return $ M.fromList $ map swap kvs
+ src/Recognize/SubExpr/Recognizer.hs view
@@ -0,0 +1,566 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the subexpression recognizer.+-- If you wish to extend the language that the subexpression recognizer accepts, see "Recognize.SubExpr.Symbols"+-- Common functions can be found in "Recognize.SubExpr.Functions"+-- If you wish to make use of the parameters of the recognizer see "Recognize.SubExpr.SEParser"+-- Finally, if you want to change/view the comparison functions see "Recognize.SubExpr.Compare"+-- Throughout the code you may find log statements. Logging is only visible if debug mode is on.+-- The algorithm is still a WIP and doesn't look very polished. It is however in a usable state (see exercises theatrerate, pattern, vpattern and matryoshka).+-- +-----------------------------------------------------------------------------++module Recognize.SubExpr.Recognizer+   ( pMatchSubSteps+   ) where++import           Control.Applicative (empty, (<|>))+import           Control.Arrow+import           Control.Monad+import           Data.Maybe+import qualified Data.Map as M+import           Domain.Math.Data.Relation+import           Domain.Math.Expr+import           Ideas.Common.Id        (newId)+import           Ideas.Common.Rewriting+import           Ideas.Common.View (from)+import Ideas.Utils.Prelude+import Recognize.Parsing.Parse+import Recognize.Data.Math+import Recognize.Parsing.Derived+import Recognize.SubExpr.SEParser+import Recognize.Expr.Functions as F+import Recognize.Expr.Normalform+import Recognize.SubExpr.Compare+import Recognize.SubExpr.Symbols+import Recognize.SubExpr.Functions as SF+import Recognize.Data.Attribute+import Recognize.Data.Diagnosis+import Recognize.Data.Step+import Util.List+import Util.Monad++-- | Accepts an expression for matching with input expressions+--+-- The algorithm parses an input as long as it matches against the given expression.+-- Input can be matched in 4 different ways.+--+-- * Input matches exactly (module commutativity, associativity)+-- * Input matches simplified+-- * Input matches exactly (..) against a subexpression+-- * Input matches simplified against a subexpression+--+-- A small example: Given an expression 1 + 2, we can match against several different combinations of input:+-- [1,2,1+2,3,3] [3,3,3] [2,1,3] etc+--+-- Note that we can no longer match an input if we had already parsed an simplified form of this input, unless+-- the+pMatchSubSteps :: Expr -> SEParser (Expr, [Step])+pMatchSubSteps m = do+  pLog $ "pMatchSubSteps: " ++ show m++  b_iter <- gets optIterate+  stop_pred <- gets matchPredicate++  -- Iterates over input matching them to an expression until no more expression matches.+  -- if we were unable to match the whole expression to some input we will fail.+  (e,st) <- pFoldAlt b_iter (\(m2,steps) -> do+    pLog ("Iteration: " ++ show m2 ++ " " ++ show steps)+    math <- peek+    pLog ("Math: " ++ show math)+    -- If we have a matched expression, then check whether we have to stop or not+    when (isMatched m2) $ pLog "stopping" >> guard (stop_pred m2)++    -- If we can't match against @math@ then we may try to skip it+    choice' [successStep (m2,steps) math, failStep (m2,steps)]+    ) (m,[]) -- initial to be matched expression++  pLog ("Can we exit pMatchSubSteps? " ++ show e ++ " | " ++ show (isMatched e))+  -- If @e@ is not matched then fail+  unless (isMatched e) empty++  -- Remove any expression constructors related to the subexpression recognizer+  -- However, this is not always possible: match 5 <&> match 6. In this case we must+  -- return 5 <$> 6.+  e2 <- pSubstituteVars e+  e3 <- maybeToParse $ getMatched e2+  let e4 = cleanExpr e3+  pLog ("Exit pMatchSubSteps: " ++ show (e4, st))+  return (e4, st)+  where+    successStep (m2,steps) math = do+      -- We take the input type specified by a parameter and attempt to parse/recognize+      -- @math@ according to that input type+      (m3, attr2) <- gets inputType >>= pMatchSubInputType m2 math+      -- If successful we can skip+      _ <- skip+      return (m3, steps ++ [Step (newId "subexpr") (math, attr2) []])+    -- Sometimes unrelated expressions can be mixed in with ones that we wish to recognize+    -- In that case we would like to skip over these and continue until we find a new expression+    -- that we can recognize+    failStep mst = do+      guardBy optSkipOnce -- Check if we can skip an expression+      modify $ \st -> st { optSkipOnce = False }+      _ <- skip+      pLog "Skip an expression"+      math <- peek+      successStep mst math++-- | Parses a @Math@ type according to the given allowed input types.+pMatchSubInputType :: Expr -> Math -> Maybe [InputType] -> SEParser (Expr, [Attribute])+pMatchSubInputType m math Nothing = do -- if none specified we try to figure out its inputtype on our own+  e <- getExpr math+  pLog ("pMatchSubInputType: " ++ show e ++ " : " ++ show (determineInputType e))+  pMatchSubInputType' m math (determineInputType e)+pMatchSubInputType m math (Just its) = do+  e <- getExpr math+  pLog ("pMatchSubInputType: " ++ show e ++ " : " ++ show (determineInputType e) ++ " " ++ show its)+  let e_inputType = determineInputType e++  guard $ any (doesTypeConform e e_inputType) its --Make sure the expression conforms to any of the input types.+  pMatchSubInputType' m math e_inputType+  where+    doesTypeConform e Linear lwt@(LinearWithType t) = e `conformsTo` lwt+    doesTypeConform _ eit it = eit == it++-- | Calls the recognizer function that corresponds to the inputtype+pMatchSubInputType' :: Expr -> Math -> InputType -> SEParser (Expr, [Attribute])+pMatchSubInputType' m math Expr = getExpr math >>= pMatchSubExpr m+pMatchSubInputType' m math Definition = getEq math >>= pMatchSubDef m+pMatchSubInputType' m math Equation = do+  che <- gets chainedEquations+  rel <- getRelation math+  pMatchSubEq che m (leftHandSide rel :==: rightHandSide rel)+pMatchSubInputType' m math Linear = do+  rel <- getRelation math+  pMatchSubLin m rel+pMatchSubInputType' m math (LinearWithType _) = pMatchSubInputType' m math Linear++-- | Match two expressions+pMatchSubExpr :: Expr -> Expr -> SEParser (Expr, [Attribute])+pMatchSubExpr m e = do+  pLog ("pMatchSubExpr: " ++ show m ++ " | " ++ show e)+  res <- pMatchSubInput (\x -> addMatching x >> return (matchExpr x)) m e+  pLog ("MatchedExpr: " ++ show m ++ " " ++ show e ++ " " ++ show res)+  return res++-- | Match an expression to an equation+--+-- First we see if we can match the two expression of the input equation. This tells us whether the equation is equal or unequal.+--+-- Next we match the expression to the left side of the equation.+--+-- Assuming everything matches we return the expression, but anything that was matched is replaced by the right side of the equation.+-- This could be the entire expression or some subterm.+pMatchSubEq :: Bool -> Expr -> Equation Expr -> SEParser (Expr, [Attribute])+pMatchSubEq _ m (x :==: y) = do+    pLog ("pMatchSubEq: " ++ show m ++ " | " ++ show x ++ " .==. " ++ show y)+    us <- resetSEState+    mxy <- option $ choice' [ (\(a,b) -> (a,b,y)) <$> pMatchSubInput return x y+                            -- , do+                            --   pLog ("CHE attempt: " ++ show (che, not (isAtom y)))+                            --   guard (che && not (isAtom y))+                            --   l <- maybeToParse $ getMostLeft y+                            --   (\(a,b) -> (a,b,l)) <$> pMatchSubInput (return . id) x l+                            ]+    put us+    -- If y is not a (simplified) subexpression of x then+    -- clearly the equation must be invalid+    let attr1 = maybe [InvalidEquation x y] (\t -> MatchedBy x y : snd3 t) mxy+    -- regardless of whether x is a subexpression of m+    -- we must continue with y+    when (isJust mxy) $ pLog ("Found Valid equation match: " ++ show mxy)+    when (isNothing mxy) $ pLog "Found Invalid equation"+    (m2,attr2) <- pMatchSubInput (\_ -> addMatching y >> return (matchExpr $ maybe y thd3 mxy)) m x++    pLog ("Matched: " ++ show m ++ " | " ++ show (x .==. y) ++ " | " ++ show m2 ++ " | " ++ show mxy)+    return (m2, filter (\a -> isLabelAttr a || isCommonMistake a) attr2 ++ attr1)++-- | Matches an expression to an equation (definition).+--+-- We only consider the right side of the equation for matching.+--+-- Since the left side of the equation may be used in further input we continue with both the left side and right side of the equation.+pMatchSubDef :: Expr -> Equation Expr -> SEParser (Expr, [Attribute])+pMatchSubDef m e@(x :==: y) = do+  pLog ("pMatchSubDef: " ++ show m ++ " | " ++ show e)+  (m2,rw) <- pMatchSubInput (\_ -> addMatching x >> addMatching y >> matchExpr <$> (return y <|> return x)) m y+  pLog ("MatchedDef: " ++ show m ++ " " ++ show e ++ " " ++ show m2)+  return (m2, rw)++-- | Match an expression to a relation+--+-- Both sides of the relation must match the expression.+pMatchSubLin :: Expr -> Relation Expr -> SEParser (Expr, [Attribute])+pMatchSubLin m rel = do+  let x = leftHandSide rel+  let y = rightHandSide rel+  pLog ("pMatchSubLin: " ++ show m ++ " | " ++ show x ++ " .==. " ++ show y)+  (m2,attrx) <- pMatchSubInput (\_ -> addMatching x >> matchExpr <$> return x) m x+  (m3,attry) <- pMatchSubInput (\_ -> addMatching y >> matchExpr <$> return y) m2 y+  return (m3,attrx++attry)++pMatchSubInput :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])+pMatchSubInput c m e =+  choice'+    [ pFindSubExpr c m e+    , do+      guardBy optGrow -- Only if we are allowed to grow can we call pMatchSubGrow+      guard (not $ hasMatch m)+      f <- gets growF+      -- pMatchSubGrow must match the entire motherexpression. Hence,+      -- if it succeeds we can simply the function c to the returned expression.+      -- This allows us to avoid c messing with the growing of the motherexpression+      applyFirstM c $ pMatchSubGrow f (\x -> addMatching x >> return (matchExpr x)) m e+    ]++-- | Using some growth function we grow the first expression if the first expression is a subexpression of the second expression.+pMatchSubGrow :: (Expr -> Expr) -> (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])+pMatchSubGrow f c m e = do+  pLog ("pMatchSubGrow " ++ show e ++ " " ++ show m)+  let alts = alternativesExpr m+  let findAlts = map (\(m2,rw) -> pFindSubExpr c e m2 >>= \(e2,_) -> return (e2,rw,m2)) alts+  (e2,rw,m2) <- choice' findAlts+  pLog $ "Matching in Grow: " ++ show e2 ++ " | " ++ show m2+  if isMatch e2+    then (\x -> (x,rw)) <$> c e+    else second (rw++) <$> pMatchSubGrow f c e2 (f (matchExpr m2))++-- | Interpreter for the subexpression recognizer language.+pFindSubExpr :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubExpr c m e = do+  pLog ("pFindSubExpr: " ++ show m ++ " " ++ show e)+  mres <- option pFindSubExpr'+  maybeToParse mres+  where+    -- Call the corresponding interpreting function+    pFindSubExpr' =+      case getFunction m of+        Nothing -> pFindSubNullary c m e+        Just (s,[])+          | isMagicNumberSymbol s -> pFindSubMagicNumber c e+          | isMagicNatSymbol s -> pFindSubMagicNat c e+          | isMagicVarSymbol s -> pFindSubMagicVar c e+        Just (s,[x])+          | isStopSymbol s     -> empty+          | isMatchSymbol s    -> pFindSubMatch c s x e+          | isSimSymbol s      -> pFindSubSim c s x e+          | isNoSimSymbol s    -> pFindSubNoSim c s x e+          | isSubSymbol s      -> pFindSubSub c s x e+          | isVarSymbol s      -> pFindSubVar c x e+          | otherwise          -> pFindSubUnary c s x e+        Just (s,[x,y])+          | isBuggySymbol s    -> pFindSubBuggy c x y e+          | isOrSymbol s       -> pFindSubOr c s x y e+          | isAndSymbol s      -> pFindSubAnd c s x y e+          | isLabelSymbol s    -> pFindSubLabel c s x y e+          | timesSymbol  == s  -> pFindSubAssoc c s (snd $ from productView m) e+          | plusSymbol   == s  -> pFindSubAssoc c s (from sumView m) e+          | divideSymbol == s  -> pFindSubDivision c s x y e+          | otherwise          -> pFindSubBinary c s x y e+        Just (s,[x,y,z])+          | isLtSymbol s       -> pFindSubLt c x y z e+        _ -> pLog ("Empty in pFindSubExpr: " ++ show m ++ " " ++ show e) >> empty++-- | Match if e is a number+pFindSubMagicNumber :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])+pFindSubMagicNumber c e = do+  guard (isNumber e)+  (\x -> (x,[])) <$> c e++-- | Match if e is a natural number+pFindSubMagicNat :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])+pFindSubMagicNat c e = do+  guard (isNat e)+  (\x -> (x,[])) <$> c e++-- | Match if e is a magic variable+pFindSubMagicVar :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])+pFindSubMagicVar c e = do+  guard (F.isVar e)+  (\x -> (x,[])) <$> c e++-- | Compare two atoms+pFindSubNullary :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubNullary c e1 e2 = do+  pLog ("pFindSubNullary: " ++ show e1 ++ " " ++ show e2)+  precision <- gets precision+  b <- pCompare (roundNumber precision e1) (roundNumber precision e2)+  guard b+  (\x -> (x,[])) <$> c e1++-- | If an expression has been matched then we do not allow a subexpression of that expression to be matched.+--+-- Instead the expression may only be simplified+pFindSubMatch :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubMatch c s m e = do+  (e,attrs) <- pMatchAlts (function s [m]) e+  let mattr = MatchedBy m e+  e' <- c e+  return (e',mattr : attrs)++-- |  The second expression must be a simplification of the first expression+pFindSubSim :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubSim c s m e = do+  b <- gets optTraverse+  dic <- gets usedVariables+  modify $ \st -> st { optTraverse = False }+  m' <- maybeToParse $ substituteAllIf SF.isVar dic m+  (m2, attrs) <- pFindSubExpr c (nf $ cleanExpr m') e+  modify $ \st -> st { optTraverse = b }+  pLog $ "pFindSubSim " ++ show m' ++ " | " ++ show m2 ++ " | " ++ show e+  if isMatched m2 && isSimplified m2+    then return (m2, attrs)+    else return (function s [m2], attrs)++-- | No simplification allowed+pFindSubNoSim :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubNoSim c s m e = do+  pLog $ "pFindSubNoSim: " ++ show m ++ " " ++ show e+  modify $ \st -> st { optSimplify = False }+  (m2, attrs) <- pFindSubExpr c m e+  modify $ \st -> st { optSimplify = True }+  return (function s [m2], attrs)++-- | First a normalized matching only after we have a matching may we match simplifications.+pFindSubSub :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubSub c s m e = do+  pLog ("pFindSubSub: " ++ show m ++ " " ++ show e)+  guardBy optTraverse+  if isMatched m+    then do+      (m2,attrs) <- pFindSubExpr c m e+      if nfComAssoc m2 == nf m2+        then return (m2,attrs)+        else return (function s [m2],attrs)+    else do+      -- If m has yet to be matched then we do not allow m to match to its simplification (an atom)+      -- e.g. m : a + b+      -- first (a + b) must be matched, and only after that may some c = a + b, match with m+      -- This does mean that sub a, where a is an atom will never succeed+      guard (hasSub m || not (isAtom e))+      sim <- gets optSimplify+      modify $ \st -> st { optSimplify = False }+      (m2, attrs) <- pFindSubExpr c m e+      modify $ \st -> st { optSimplify = sim }+      pLog ("pFindSubSub: " ++ show m2)+      if isMatched m2 && nfComAssoc m2 == nf m2+        then return (m2, attrs)+        else return (function s [m2], attrs)++pFindSubVar :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubVar c (Var v) e = do+  pLog ("pFindSubVar: " ++ show v ++ " " ++ show e)+  vars <- gets usedVariables+  -- Look up the variable in the dictionary+  let mx = M.lookup v vars+  -- If the variable doesn't exist we fail parsing+  x <- maybeToParse mx++  -- For now we don't traverse into the found expression+  -- It is likely that we only bind variables to magic numbers,+  -- whose value change after matching it to some input+  (x2, attrs) <- applyFirstM c $ pMatchAlts x e+  -- Update the variable in the dictionary+  modify $ \st -> st { usedVariables = M.insert v x2 vars }+  pLog ("End of pFindSubVar: " ++ show x2)+  return (x2,attrs)+pFindSubVar _ _ _ = empty++-- | Match something that has a single parameter+pFindSubUnary :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubUnary c s m e =+  choice [ do+    guardBy optTraverse -- Are we allowed to traverse?+    (m2,rw) <- pFindSubExpr c m e+    return (function s [m2], rw)+         ,+    applyFirstM c $ pMatchAlts (function s [m]) e+  ]++-- | Match 'correct' left or 'incorrect' right+pFindSubBuggy :: (Expr -> SEParser Expr) -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubBuggy c x y e = do+  pLog ("pFindSubBuggy: " ++ show x ++ "  " ++ show y ++ " " ++ show e)+  choice+    [ do+      pLog "Go in Left"+      pFindSubExpr c x e+    , do+      pLog "Go in Right"+      second (CommonMistake:) <$> pFindSubExpr c y e+    ]++-- | Match left or right+pFindSubOr :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubOr c s x y e = do+  pLog ("pFindSubOr: " ++ show x ++ " " ++ show y ++ " " ++ show e)+  (eth, attr) <- choice+    [ first Left <$> pFindSubExpr c x e+    , first Right <$> pFindSubExpr c y e+    ]++  case eth of+    Left x' -> return (function s [x',y], attr)+    Right y' -> return (function s [x,y'],attr)++-- | Match left and right+pFindSubAnd :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubAnd c s x y e = do+  pLog ("pFindSubAnd: " ++ show x ++ " " ++ show y ++ " " ++ show e)+  (eth, attr) <- choice+    [ first Left <$> pFindSubExpr c x e+    , first Right <$> pFindSubExpr c y e+    ]++  case eth of+    Left x' -> return (function s [x',y], attr)+    Right y' -> return (function s [x,y'],attr)++-- | Make a label attribute if the expression matches+pFindSubLabel :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubLabel c s lbl@(Var l) x e = do+  pLog ("pFindSubLabel: " ++ show lbl ++ " " ++ show x ++ " " ++ show e)+  (m,attr) <- pFindSubExpr c x e++  return $+    if isMatched m+      then (m, Label l : attr)+      -- Make sure to not throw away the label if we do not yet want to use it+      else (function s [lbl, m], attr)+pFindSubLabel _ _ _ _ _ = empty -- Shouldn't be possible, but we don't statically enforce it+++-- | For division we need to be careful in that there can be many different subexpression of a division.+--+-- For example if we have (5+6)/8, then 5/8,6/8,5+6,8 are all subexpressions. The third case of the choice deals with this.+pFindSubDivision :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubDivision c s x y e = do+  pLog ("pFindSubDivision: " ++ show s ++ "  " ++ show x ++ "  " ++ show y ++ " " ++ show e)+  choice [ do+    -- Go into the left branch+    guardBy optTraverse+    (x2,rw) <- pFindSubExpr c x e+    return (function s [x2,y], rw)+         , do+    -- Go into the right branch+    guardBy optTraverse+    (y2, rw) <- pFindSubExpr c y e+    return (function s [x,y2], rw)+         , do+    -- determine whether the top side of the division is a sum or a product.+    (opS, xs) <- choice'+      [ succeedIf (\xs -> length xs > 1) (plusSymbol, from sumView x)+      , succeedIf (\xs -> length xs > 1) (timesSymbol, snd $ from productView x)+      ]+    choice [ do+      -- For (a * b * c / d)+      -- try [a/d,b/d,c/d]+      guardBy optTraverse+      ((z,rw),zs) <- choiceFor' (selections xs) $ \(x,xs) -> pFindSubExpr c (x/y) e >>= \res -> return (res,xs)+      return (function s (z:zs), rw)+           , do+      -- For (a * b * c / d) and e+      -- Try to find a sub match of (a * b * c) in e * d+      (x2,attr) <- pFindSubAssoc c opS xs (e*y)+      return (function s [x2,y], attr)+      ]  ,+    applyFirstM c $ pMatchAlts (function s [x,y]) e+    ]++-- | Match an expression to one or both of the arguments of some binary expression.+pFindSubBinary :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubBinary c s x y e = do+  pLog ("pFindSubBinary:" ++ show s ++ " " ++ show x ++ "  "  ++ show y ++ "  " ++ show e)+  choice+    [ do+      guardBy optTraverse+      (x2,rw) <- pFindSubExpr c x e+      return (function s [x2,y], rw)+    , do+      guardBy optTraverse+      (y2, rw) <- pFindSubExpr c y e+      return (function s [x,y2], rw)+    , applyFirstM c $ pMatchAlts (function s [x,y]) e+    ]++-- | For expressions that are associative we need to take special consideration.+--+-- For example if we have 5 + 6 + 7 then possible subexpressions are: 5,6,7,5+6,5+7,6+7.+pFindSubAssoc :: (Expr -> SEParser Expr) -> Symbol -> [Expr] -> Expr -> SEParser (Expr, [Attribute])+pFindSubAssoc c s xs e = do+  pLog ("pFindSubAssoc : " ++ show s ++ " " ++ show xs ++ " | " ++ show e)+  -- Given a list [1 , 2<!>3 , 4]+  -- selections = [(4,[1,2<!>3]) , (2<!>3,[1,4]) , (1,[2<!>3,4])] -- pick each component one time+  -- map second subExprCombs = [(4,[([1,2],[]) , ([1,3],[common mistake])]), ...] -- produce all combinations  of the remaining components for each picked component+  -- map first (:[]) = [([4],[([1,2],[]),([1,3],[common mistake])]), ...]+  -- concatMap uncurry cartProd = [(4,([1,2],[])) , (4,([1,3],[common mistake])), ...]+  let subCombsCartProd = concatMap (uncurry cartProd . first (: []) . second subExprsCombs) $ selections xs+  pLog $ "Assoc tempts: " ++ show subCombsCartProd+  choice+    [ choiceFor subCombsCartProd $ \(y,(ys,attr)) -> do+        pLog ("Assoc attempt: " ++ show y ++ " " ++ show ys ++ " | " ++ show e)+        (ys',attr2) <- pFindSubExpr c (function s ys) e+        return (function s [y,ys'],attr ++ attr2)+    , do+      (e,attr) <- pMatchAlts (function s xs) e+      e' <- c e+      return (e',attr)+    ]++-- | Introduce a subexpression variable and add it to the mapping in the user state+pFindSubLt :: (Expr -> SEParser Expr) -> Expr -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])+pFindSubLt c (Var v) x y e = do+  pLog ("pFindSubLt: " ++ show v ++ " " ++ show x ++ " " ++ show y ++ " " ++ show e)+  modify $ \st -> st { usedVariables = M.insert v x (usedVariables st) }+  pFindSubExpr c y e+pFindSubLt _ _ _ _ _ = empty++-- | We use this function to generate all possible expressions and then have each expression be compared to the second expression.+--+-- see `alternativesExpr` to see how these expression are generated.+pMatchAlts :: Expr -> Expr -> SEParser (Expr, [Attribute])+pMatchAlts m e = do+  pLog $ "pMatchAlts: " ++ show m ++ " | " ++ show e+  pLog $ "pMatch alts: " ++ show alts+  choiceFor alts $ \(m1,attrs) -> do+    pLog ("pMatchAlt: " ++ show m1 ++ " | " ++ show e)+    choice'+      [ do+        guardBy optSimplify+        guard (not $ hasSub m1)+        (_, _, z) <- pCompareBySimplify m1 e+        pLog "Simplified equal"+        -- If some subexpression has a label then we wish to generate it now+        attrs' <- pGatherLabels m1+        return (e, attrs' ++ attrs ++ z)+      , do+        pLog "Compare normalized"+        -- guard (hasMagicNat m || SF.hasVar m)+        (_, y) <- pCompareByNormalize m1 e+        pLog "Normalized equal"+        attrs' <- pGatherLabels m1+        return (e, attrs' ++ attrs ++ y)+      ]+  where+    alts = alternativesExpr m++-- | Gather all labels that we can find in the subexpression+pGatherLabels :: Expr -> SEParser [Attribute]+pGatherLabels m = case getFunction m of+  Nothing -> return []+  Just (s,[Var l,y])+    | isLabelSymbol s -> (Label l:) <$> pGatherLabels y+  Just (s,[Var l, e,y])+    | isLabelSymbol s -> do+      e' <- pSubstituteVars e+      (LabelE l e':) <$> pGatherLabels y+  Just (_,xs) -> concat <$> mapM pGatherLabels xs
+ src/Recognize/SubExpr/SEParser.hs view
@@ -0,0 +1,134 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Recognize.SubExpr.SEParser+  ( -- * SubExpression Parser+    SEParser, get, put, gets, modify, seParse+  -- * User state+  , SEState(..), getVarKey, addMatching+  -- * Input type+  , InputType(..), determineInputType, conformsTo, resetAfter, resetSEState+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.State+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Set as S+import Domain.Math.Expr+import Domain.Math.Data.Relation+import Recognize.Data.Math+import qualified Recognize.Expr.Functions as F+import Recognize.SubExpr.Functions+import Recognize.Parsing.Parser+import Control.Monad.Identity++-- | Describes some math type+data InputType = Expr | Definition | Equation | LinearWithType RelationType | Linear deriving (Eq,Show)++-- | Given an expression, check whether it matches the specified input type.+conformsTo :: Expr -> InputType -> Bool+conformsTo e Expr = isNothing $ getEqE e+conformsTo e Definition = isJust $ do+  (x :==: _) <- getEqE e+  guard $ isFunctionCall x || F.isVar x+conformsTo e Equation = isJust $ do+  rel <- getRelationE e+  let x = leftHandSide rel+  let y = rightHandSide rel+  guard (not (F.hasVar x || F.hasVar y) && not (isFunctionCall x))+conformsTo e Linear = isJust $ do+  rel <- getRelationE e+  let x = leftHandSide rel+  let y = rightHandSide rel+  guard (not (F.isVar x) && (F.hasVar x || F.hasVar y))+--LinearWithType is a  linear expression with the given relationType.+conformsTo e (LinearWithType t) = (conformsTo e Linear) && (isJust $ do+  rel <- getRelationE e+  let sym = relationType rel+  guard (sym == t))++-- | Determine the input type of the given expression+determineInputType :: Expr -> InputType+determineInputType e+  | e `conformsTo` Definition = Definition+  | e `conformsTo` Equation = Equation+  | e `conformsTo` Linear = Linear+  | e `conformsTo` (LinearWithType EqualTo) = Linear+  | e `conformsTo` (LinearWithType LessThan) = Linear+  | otherwise = Expr++-- | The user state of the subexpression recognizer+--+-- It carries parameters for the recognizer, mapping of vars to expressions and other information+data SEState = SEState+  { optGrow          :: Bool -- Let the mother expression grow+  , growF            :: Expr -> Expr -- Grow function+  , optIterate       :: Bool -- Try more than one iteration+  , optTraverse      :: Bool -- Allow traversal of mother expression+  , optSimplify      :: Bool -- ^ Allow simplification of mother expression+  , optSkipOnce      :: Bool -- Allow expressions to be skipOnced+  , chainedEquations :: Bool -- Does the solution contain chained equations? Then maybe we want to parse differently.+  , precision        :: Int -- Number of decimals that are kept in simplification+  , matchings        :: S.Set Expr+  , usedVariables    :: M.Map String Expr -- Variables that are known to be used+  , inputType        :: Maybe [InputType] -- ^ Type of expressions that may be parsed+  , matchPredicate   :: Expr -> Bool+  }++-- | Default user state+emptyState :: SEState+emptyState = SEState+  { optGrow          = False+  , growF            = id+  , optIterate       = True+  , optTraverse      = True+  , optSimplify      = True+  , optSkipOnce      = False+  , chainedEquations = False+  , precision        = 2+  , matchings        = S.empty+  , usedVariables    = M.empty+  , inputType        = Nothing+  , matchPredicate   = const True+  }++type SEParser = ParserT SEState Math Identity++seParse :: SEParser a -> [Math] -> Maybe a+seParse p ss =+   case runIdentity (runParserT p emptyState ss) of+      [] -> Nothing+      (a, _, _):_ -> Just a++getVarKey :: Expr -> SEParser String+getVarKey (Sym s [Var x]) = guard (isVarSymbol s) >> return x+getVarKey _ = empty++addMatching :: Expr -> SEParser ()+addMatching e =+   modify $ \st -> st { matchings = S.insert e (matchings st) }++-- | Reset the user state to `dSEState` after executing the parser+resetAfter :: SEParser a -> SEParser a+resetAfter sp = do+  a <- sp+  put emptyState+  return a++-- | Reset the user state to `dSEState`. Returns the user state before resetting.+resetSEState :: SEParser SEState+resetSEState = do+  us <- get+  put emptyState+  return us
+ src/Recognize/SubExpr/Symbols.hs view
@@ -0,0 +1,160 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module defines the language of the subexpression recognizer.+-- +-- We make use of the open data-type `Expr` to combine both already existing constructors and new constructors defined here.+-- +-- If you want to add a new symbol to the language, you must do the following:+-- +-- * Create the symbol and corresponding `Expr` constructor in this module+-- * Add a function named 'pFindSubXXX', in "Recognize.SubExpr.Recognizer". Add a call to that function in `pFindSubExpr`.+-- * Add existence functions in "Recognize.SubExpr.Functions".+-- * Some functions in "Recognize.SubExpr.Functions" may require modification, such as `cleanExpr`. Make sure you thoroughly go over the functions in that file and modify where necessary.+--+-----------------------------------------------------------------------------++module Recognize.SubExpr.Symbols where++import Ideas.Common.Rewriting+import Domain.Math.Expr.Data++-------------------------------------------------------------+-- Symbols+-------------------------------------------------------------++buggySymbol :: Symbol+buggySymbol = newSymbol "buggySymbol"++orSymbol :: Symbol+orSymbol = newSymbol "or"++andSymbol :: Symbol+andSymbol = newSymbol "and"++varSymbol :: Symbol+varSymbol = newSymbol "var"++ltSymbol :: Symbol+ltSymbol = newSymbol "lt"++matchSymbol :: Symbol+matchSymbol = newSymbol "match"++magicVarSymbol :: Symbol+magicVarSymbol = newSymbol "magicVar"++magicNatSymbol :: Symbol+magicNatSymbol = newSymbol "magicNat"++magicNumberSymbol :: Symbol+magicNumberSymbol = newSymbol "magicNumber"++labelSymbol :: Symbol+labelSymbol = newSymbol "label"++stopSymbol :: Symbol+stopSymbol = newSymbol "stop"++simSymbol :: Symbol+simSymbol = newSymbol "simpl"++noSimSymbol :: Symbol+noSimSymbol = newSymbol "noSimpl"++subSymbol :: Symbol+subSymbol = newSymbol "sub"++--------------------------------------------------------------+-- Expression defined using the above symbols+--------------------------------------------------------------++-- | Gives us a way to say that matching to an expression is deemed incorrect.+--+-- It takes two expressions. Matching the first is 'correct' and matching the second is 'incorrect.+--+-- Other than that, it behaves similarly to 'or'.+infixl 3 <!>+(<!>) :: Expr -> Expr -> Expr+a <!> b = Sym buggySymbol [a, b]++-- | 'or' between expressions+--+-- Match the first or the second. It is possible for both to be matched.+infixl 3 <?>+(<?>) :: Expr -> Expr -> Expr+a <?> b = Sym orSymbol [a,b]++-- | 'and' between expressions+--+-- Both expressions must be matched+infixl 0 <&>+(<&>) :: Expr -> Expr -> Expr+x <&> y = Sym andSymbol [x,y]++-- | Mutable variable.+--+-- This is different from the `Expr` Var constructor in that this var acts as a reference to some expression.+--+-- It is also possible for this expression to change, but only from some magic expression type to some more concrete expression type.+var :: String -> Expr+var s = Sym varSymbol [Var s]++-- | Let expression+--+-- Introduces mutable variables by assigning it some default value.+--+-- It takes a string to be used as an identifier (make sure it is unique). The default value and+--+-- a function whose argument is the introduced mutable variable.+lt :: String -> Expr -> (Expr -> Expr) -> Expr+lt s e f = Sym ltSymbol [Var s, e, f $ var s]++-- | Tells us that an expression has been matched by the recognizer+matchExpr :: Expr -> Expr+matchExpr e = Sym matchSymbol [e] -- clean?++-- | Matches any variable+newMagicVar :: Expr+newMagicVar = Sym magicVarSymbol []++-- | Matches any natural number+newMagicNat :: Expr+newMagicNat = Sym magicNatSymbol []++-- | Matches any number+newMagicNumber :: Expr+newMagicNumber = Sym magicNumberSymbol []++-- | Label an expression (generates an `Attribute`)+lbl :: String -> Expr -> Expr+lbl x e = Sym labelSymbol [Var x, e]++-- | Same as `lbl`, but also includes an expression in the label.+lblE :: String -> Expr -> Expr -> Expr+lblE l x e = Sym labelSymbol [Var l, x, e]++-- | Stops further traversing into the expression+stop :: Expr -> Expr+stop x = Sym stopSymbol [x]++-- | An expression must be completely simplified before we consider it to be matched.+sim :: Expr -> Expr+sim x = Sym simSymbol [x]++-- | No simplification allowed+--+-- Turns of simplification in the recognizer+noSim :: Expr -> Expr+noSim x = Sym noSimSymbol [x]++-- | First requires a normalized matching before a simplified form can match+sub :: Expr -> Expr+sub x = Sym subSymbol [x]
+ src/Service/AdviseMe.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Service.AdviseMe (runService, adviseMeDr, runDomainReasoner) where++import Database.SQLite.Simple.ToField+import Ideas.Service.Types hiding (tUserId)+import Ideas.Text.HTML+import Ideas.Text.XML+import Recognize.Data.DiagnoseResult+import Data.List+import Data.Maybe+import Recognize.Data.Entry+import Recognize.Data.MathStoryProblem+import Recognize.Data.Solution+import Main.Tasks+import Bayes.Script+import Bayes.StudentReport (StudentReport)+import Service.Sequencer+import Service.Types+import Util.W3CSSHTML+import Ideas.Common.Library+import Ideas.Main.Default+import Ideas.Encoding.Request (Schema(V2))+import Ideas.Encoding.ModeXML (processXML)+import Ideas.Encoding.Options (logRef, maxTime)++import qualified Ideas.Encoding.Logging as Log+import qualified Database.HDBC as SQL+import qualified Database.HDBC.Sqlite3 as SQL (connectSqlite3, setBusyTimeout)+import Database.Data++-- COMPILER BUG? instance needed?+instance ToField Rational where+ toField d = let x = fromRational d :: Double+             in toField x++-- | Run the Advise-Me domain reasoner, and then afterwards the Bayesian+-- networks. We defer logging of the request so that the request and the+-- student model are logged in one fell swoop.+runService :: IO ()+runService = do+      ref <- Log.makeLogRef "advise-me.db" V2+      Log.disableLogging ref+      defaultMainWith (mempty {logRef=ref}) adviseMeDr+      conn <- SQL.connectSqlite3 (fromJust $ Log.getFilePath ref)+      SQL.setBusyTimeout conn 1000 -- milliseconds+      Log.logRecordWith ref conn+      addModelToLatestRequest conn --temporarily turned off: no BN+      --calculation!+      SQL.commit conn+      SQL.disconnect conn++adviseMeDr :: DomainReasoner+adviseMeDr = describe "Advise-Me domain reasoner" (newDomainReasoner "advise-me")+   { exercises = map (\(Task e) -> Some (getExercise e)) tasks+   , services  = myServices+   }++myServices :: [Service]+myServices = adviseMeUserModelService+           : assessmentService+           : sequencerService+           : metaServiceList adviseMeDr ++ serviceList+           -- : adviseMeService++adviseMeUserModelService :: Service+adviseMeUserModelService = makeService "advise-me-usermodel" "Obtain user models for Advise-Me" $+   adviseMeUserModel ::: tUserRequest .-> tIO tStudentReports++-- | Request to obtain the user model.+adviseMeUserModel :: UserRequest -> IO [StudentReport]+adviseMeUserModel userRequest = do+   conn <- SQL.connectSqlite3 "advise-me.db"+   reports <- mapM (latestStudentReport conn (lang userRequest)) (ids userRequest)+   SQL.disconnect conn+   return reports++assessmentService :: Service+assessmentService = makeService "advise-me" "Assessment service for Advise-Me project" $+ assess ::: tExercise .-> tSource .-> tSolution .-> tIO tDiagnosis++assess :: Exercise a -> Source -> Solution -> IO (DiagnosisReply a)+assess ex src sol = do+   Task e <- findTask (getId ex)+   return $ DiagnosisReply+      { exercise = ex+      , solution = sol+      , source = src+      , entry = diagnose e sol+      , examinator = Just "ideas"+      }++-- | Run the domain reasoner directly, on a single input, without logging.+-- Intended for internal usage.+runDomainReasoner :: String -> IO String+runDomainReasoner inputString = do+   (_, reply, _) <- processXML options adviseMeDr inputString+   return reply++   where+   options = mempty { logRef = mempty+                    , maxTime = Just 5 }
+ src/Service/Sequencer.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Service.Sequencer where++import System.Random+import qualified Database.HDBC as SQL+import qualified Database.HDBC.Sqlite3 as SQL (connectSqlite3, setBusyTimeout)++import Ideas.Common.Library+import Ideas.Service.Types hiding (tUserId)+import Recognize.Data.MathStoryProblem+import Recognize.Data.Solution+import Main.Tasks+import Service.Types+import Database.Data ( StudentID, tasksDone )++sequencer :: StudentID -> IO (Maybe (Exercise a))+sequencer uid = do +   conn <- SQL.connectSqlite3 "advise-me.db"+   done <- tasksDone conn uid+   let undone = filter (\t -> not $ showId t `elem` done) tasks+   i <- randomRIO (0, length undone-1)+   if null undone+      then return Nothing+      else case undone !! i of+            Task e -> return . Just . getExercise $ e+++sequencerService :: Service+sequencerService = makeService "advise-me-next-task" "Sequencer service for Advise-Me project" $+   sequencer ::: tUserIdTag .-> tIO (tMaybe tExercise)
+ src/Service/Types.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Service.Types where++import Ideas.Text.XML (ToXML, toXML, Attribute((:=)) )+import Ideas.Common.Library           hiding (recognize)+import Ideas.Service.Types            hiding (tUserId)+import Recognize.Data.Solution+import Util.String+import Bayes.StudentReport (StudentReport)+import Control.Monad+import Data.Maybe (fromMaybe)+import Data.List (intercalate)+import qualified Ideas.Text.XML as XML+import Recognize.Data.Entry (Entry, diagnoses)+import Recognize.Data.DiagnoseResult (evidence)+import Database.Data ( StudentID )++tSolution :: Type a Solution+tSolution = Tag "solution" $ Iso (f <-> g) tp+ where+   tp = tTuple4 tUserId tGroupId tLanguage (tList tInput)+   f (userId, groupId, lan, inps) = Solution userId groupId lan inps+   g (Solution userId groupId lan inps) = (userId, groupId, lan, inps)++tUserId :: Type a UserId+tUserId = tMaybe $ tAttr "userid"++tGroupId :: Type a GroupId+tGroupId = tMaybe $ tAttr "groupid"++tSource :: Type a Source+tSource = tMaybe $ tAttr "source"++tLanguage :: Type a (Maybe Language)+tLanguage = tMaybe $ Iso (f <-> g) $ tAttr "language"+ where+   f = read . strToUpper+   g = strToLower . show++tInput :: Type a Input+tInput = Tag "input" $ Iso (f <-> g) tp+ where+   tp = tPair tInputId (tList (tMathML :|: tString))+   f (inputId, xs) = Input inputId xs+   g (Input inputId xs) = (inputId, xs)++tInputId :: Type a Id+tInputId = Iso (newId.strToLower <-> show) $ tAttr "id"++tAttr :: String -> Type a String+tAttr s = Tag s tString++tStudentReport :: Type a StudentReport+tStudentReport = Tag "StudentReport" $ Iso (f <-> toXML) tXML+ where+   f = error "student report from xml not implemented" --either error id . Report.fromXML++tStudentReports :: Type a [StudentReport]+tStudentReports = Iso (f <-> g) tXML+   where+   f = error "student reports from xml not implemented"+   g reports = XML.makeXML "users" $ mconcat $ map (XML.builder . toXML) reports+++-- | DiagnosisReply is a datatype that purely exists as an intermediate between+-- the date types we gather and the XML we show to the user.+data DiagnosisReply a = DiagnosisReply +   { exercise :: Exercise a+   , solution :: Solution+   , entry :: Entry+   , source :: Maybe String+   , examinator :: Maybe String+   }++instance ToXML (DiagnosisReply a) where+   toXML diag = XML.makeXML "diagnosis" $ mconcat +      [ "source"     XML..=. fromMaybe "" (source diag)+      , "user"       XML..=. fromMaybe "" (userId $ solution diag)+      , "exercise"   XML..=. showId (exercise diag)+      , "inputs"     XML..=. intercalate "," (map (showId . getInputId) (inputs $ solution diag))+      , "examinator" XML..=. fromMaybe "" (examinator diag)+      , XML.builder . XML.toXML . mconcat . map evidence . diagnoses . entry $ diag+      , XML.tag "debug" . XML.text . entry $ diag+      ]++tDiagnosis :: Type a (DiagnosisReply b)+tDiagnosis = Tag "Diagnosis" $ Iso (f <-> toXML) tXML+ where+   f = error "diagnosis from xml not implemented"++++-- | UserRequest is a datatype that is used only to collect a group of users+-- and a language for the user-model requests.+data UserRequest = UserRequest+   { ids :: [String]+   , lang :: String+   }+++tUserRequest :: Type a UserRequest+tUserRequest = Tag "users" $ Iso (f <-> g) tXML+   where+   g = error "UserRequest cannot be written to xml, only parsed"+   f xml = either error id $ do+      unless (XML.name xml == "users") $ fail "Expecting <users> tag" +      lang' <- XML.findAttribute "language" xml+      let ids' = map XML.getData $ XML.findChildren "userid" xml+      return $ UserRequest { ids = ids', lang = lang' }+++tUserIdTag :: Type a String+tUserIdTag = Tag "userid" $ Iso (f <-> g) tXML+   where+   g = error "StudentID cannot be written to xml, only parsed"+   f xml = do+            unless (XML.name xml == "userid") $ fail "expecting <userid> tag"+            XML.getData xml
+ src/Task/AreaAndExpression.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.AreaAndExpression (areaAndExpression) where++import Control.Monad+import Data.Maybe+import Data.Semigroup+import Domain.LinearAlgebra.Matrix+import Domain.Math.Data.MultivariatePolynomial+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Ideas.Common.Library hiding (Recognizable, steps, parser, recognizer)+import Recognize.Data.Approach (Approach (Algebraic))+import Bayes.Evidence+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Data.MathStoryProblem+import Recognize.Data.MathParserOutput+import Recognize.Data.Solution+import Recognize.Data.Step+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Parsing.Derived+import Recognize.Parsing.Interpretation+import Recognize.Recognizer+import Data.List+import Util.String+import qualified Data.Map as M+import Task.Network.AreaAndExpression++areaAndExpression :: MathStoryProblem+areaAndExpression = mathStoryProblem+   { problemId     = newId "areaandexpression"+   , processInputs = return . mergeInputs+   , analyzers     = [(mergedId, ana)]+   , inputFile     = Just "input/areaandexpression.csv"+   , networkFile   = Just "networks/AreaAndExpression.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { parser     = mathParser mempty . stringLexerOutput+      , recognizer = defaultRecognizer pDiagnosis . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False . mconcat . map assessSteps . steps+      }++mergedId :: Id+mergedId = newId "areaandexpression.concatenated"++mergeInputs :: [Input] -> Input+mergeInputs is = Input mergedId $ map strBool $ concat+   [ searchFor (newId "08a")+   , searchFor (newId "08b")+   , [Right "0"]+   , searchFor (newId "08c")+   , searchFor (newId "08d")+   , searchFor (newId "08e")+   , searchFor (newId "08f")+   , searchFor (newId "08g")+   , [Right "0"]+   ]+ where+   strBool (Right s) | strToLower s == "true" = Right "1"+   strBool (Right s) | strToLower s == "false" = Right "0"+   strBool s = s++   searchFor k =+      maybe [Right ""] getInput (find ((== k) . getInputId) is)++assessSteps :: Step -> Evidence+assessSteps s | getId s == newId "s1" = ans1 .== stepCorrect+              | getId s == newId "s2" = ans1 .== stepCorrect+              | otherwise = ans1 .== False+ where stepCorrect = (any correctAttribute . snd . getValue) s+       correctAttribute (Other s) | s == "S1" = True+                                  | s == "S2" = True+                                  | otherwise = False+       correctAttribute _                     = False++correct1 :: Matrix Expr+correct1 = makeMatrix+ [ [0, 0, 0]+ , [1 , 1 , 1]+ , [0, 1 , 0]+ ]++correct2 :: Matrix Expr+correct2 = makeMatrix+ [ [0, 1, 0]+ , [0, 1 , 1]+ , [0, 1 , 0]+ ]++termMatrix :: Matrix Expr+termMatrix = makeMatrix+  [ [ x :*: y+    | y <- [Var "y", Var "x", 1]+    ]+  | x <- [Var "y", Var "x", Var "x"]+  ]++solution :: Matrix Expr+solution = mapMul correct1 termMatrix++mapMul :: Num a => Matrix a -> Matrix a -> Matrix a+mapMul a b = makeMatrix $ zipWith (zipWith (*)) (rows a) (rows b)++matrixToExpr :: Matrix Expr -> Expr+matrixToExpr = simplify (multivariatePolynomialViewWith rationalView) . to sumView . concat . rows++pDiagnosis :: InterpretationParser Diagnosis+pDiagnosis = (newDiagnosis Algebraic . singleton) <$>+          toStep (newId "S1")+                 (do x <- pReplicate 3 (pReplicate 3 pAnyExpr)+                     guard (all (\y -> y == 0 || y == 1) (concat x))+                     f (makeMatrix x))+ where+  f :: Matrix Expr -> InterpretationParser [Attribute]+  f x | x == correct1 = return [ Other "S1" ]+      | x == correct2 = return [ Other "S2" ]+      | otherwise = return $ fromMaybe [] $ do+          xp <- (toMultivariatePolynomial . matrixToExpr) (mapMul termMatrix x)+          yp <- (toMultivariatePolynomial . matrixToExpr) solution+          yss <- (mapM (\(fs,c) -> ((,) fs <$> match naturalView c) ) . M.toAscList . multivariatePolynomialToMap) yp+          xss <- (mapM (\(fs,c) -> ((,) fs <$> match naturalView c) ) . M.toAscList . multivariatePolynomialToMap) xp+          return (g xss yss)+  g :: [(Factors,Integer)] -- ^ The sorted (by factors) representation of factors and coefficients of the input term+    -> [(Factors,Integer)] -- ^ The sorted representation of factors and coefficients of the solution.+    -> [Attribute]+  g ((xf,xc) : xs) [] = Other (show (Nat xc :*: fromFactors xf) ++ " is incorrect") : g xs []+  g [] ((yf,yc) : ys) = Other (show (Nat yc :*: fromFactors yf) ++ " is missing") : g [] ys+  g xss@((xf,xc):xs) yss@((yf,yc):ys)+     | yf == xf , yc == xc = g xs ys  -- equivalent factors and terms+     | yf == xf , yc > xc = Other ("Missing "++ show (yc - xc) ++ " of " ++ show yf) : g xs ys+     | yf == xf , yc < xc = Other (show (xc - yc) ++ " too much of "++ show yf) : g xs ys+     | yf > xf = Other (show (Nat xc :*: fromFactors xf) ++ " is incorrect") : g xs yss+     | yf < xf = Other (show (Nat yc :*: fromFactors yf) ++ " is missing") : g xss ys+  g _ _ = []
+ src/Task/AreaOfATriangle.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE TupleSections, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.AreaOfATriangle (areaOfATriangle) where++import Control.Applicative+import Control.Monad+import Data.List+import Data.Semigroup+import Domain.Math.Expr+import Ideas.Common.Library hiding ((|>), steps, parser, recognizer)+import Recognize.Data.MathParserOptions+import Recognize.Parsing.Derived+import Recognize.Data.Math+import Util.Expr+import Data.Bool+import Recognize.Data.Approach (Approach (Algebraic, Arithmetic))+import Recognize.Data.Attribute+import Recognize.Data.MathStoryProblem+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Data.StringLexerOptions+import Recognize.Expr.Normalform+import Recognize.Parsing.Interpretation+import Recognize.Parsing.Parse+import Recognize.Recognizer+import Bayes.Evidence+import Recognize.Data.Step+import Bayes.Network+import Task.Network.AreaOfATriangle++areaOfATriangle :: MathStoryProblem+areaOfATriangle = mathStoryProblem+   { problemId  = newId "areaofatriangle"+   , analyzers  = [ (newId "09a", ana9a)+                  , (newId "09b", ana9b)+                  , (newId "09c", ana9c)+                  ]+   , inputFile   = Just "input/areaofatriangle.csv"+   , networkFile = Just "networks/AreaOfATriangle.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { lexer  = stringLexer stringLexerOptions {variableWhitelist = concatMap permutations ["abc","ab","bc","ac","bdef","cd","bf","de","fe"]}+      , parser = mathParser mathParserOptions {multByConcatenation = False,convertToLowercase = True} . stringLexerOutput+      }+   ana9a = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ1) . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False .+           (\d -> makeAnswer ans1 ["Q1.S1"] d+            <> mconcat (map assessStep1 (steps d)))+      }+   ana9b = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ2) . mathParserOutput+      , collector  = evidenceOfAbsence ans2 False .+            (\d -> makeAnswer ans2 ["Q2.S1"] d+            <> mconcat (map assessStep2 (steps d)))+      }+   ana9c = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ3) . mathParserOutput+      , collector  = evidenceOfAbsence ans3 False .+            (\d -> makeAnswer ans3 ["Q3.A3","Q3.S3"] d+            <> ans3Strat .==  bool "Algebraic" "Numeric" (any ((`elem` [newId "Q3.A1", newId "Q3.A2", newId "Q3.A3"]) . getId) (steps d))+            <> mconcat (map assessStep3 (steps d)))+      }++makeAnswer :: IsId a => Node Bool -> [a] -> Diagnosis -> Evidence+makeAnswer s fs d = s .== ind+ where+   ind = any (\stp -> let atts = snd (getValue stp)+                             in+                             --elem Normalized atts && -- the final answer is+                             --still correct even if it is not normalized+                                getId stp `elem` map newId fs+                             && not (any (liftM2 (||) isMistake isApproximation) atts)) (steps d)++assessStep1 :: Step -> Evidence+assessStep1 s+   | getId s == newId "Q1.S1" = step .== Just stepCorrect+   | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)+   step | Normalized `elem` snd (getValue s) = ans1Strat1Step2+        | otherwise = ans1Strat1Step1+++assessStep2 :: Step -> Evidence+assessStep2 s+   | getId s == newId "Q2.S1" = mconcat (map (.== Just stepCorrect) step)+   | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)+   step | Normalized `elem` snd (getValue s) = [ans2Strat1Step1, ans2Strat1Step2]+        | otherwise = [ans2Strat1Step1]++assessStep3 :: Step -> Evidence+assessStep3 s+   | getId s == newId "Q3.S1" =+        ans3Strat1Step1 .== Just stepCorrect+   | getId s == newId "Q3.S2" =+        ans3Strat1Step2 .== Just stepCorrect+   | getId s == newId "Q3.S3" =+        ans3Strat1Step3 .== Just stepCorrect+   | getId s == newId "Q3.A1" =+        ans3Strat2Step1 .== Just stepCorrect+   | getId s == newId "Q3.A2" =+        ans3Strat2Step2 .== Just stepCorrect+   | getId s == newId "Q3.A3" =+        ans3Strat2Step3 .== Just stepCorrect+   | otherwise =+        mempty+ where+   stepCorrect = not (hasMistakes s)++ab :: Interpretation+ab = interpret 10 <|> interpret (Var "ab")++x :: Interpretation+x =  interpret (Var "a")+ <|>  interpret (Var "x") -- old variable name+ <|> interpret (Var "bc") <! Sloppiness  -- exercise explicitly requires answer in terms of x.++abc :: Interpretation+abc = (ab >*< x+   <|> ab >+< x <! OperatorMixedUp plusSymbol timesSymbol <! Other "M6"+      ) >>/<< interpret 2+  <|> ab >*< x <! Misconception Rectangle Triangle <! Other "M2"+  <|> (ab >+< x) >*< interpret 2 <! Misconception Perimeter Area <! Other "M3"+  <|> ((ab >+< x+  <|> ab >^< interpret 2 >+< x >^< interpret 2) >^< (interpret 1 >/< interpret 2)) >^< interpret 2 <! Misconception Perimeter Area <! Other "M4"+  <|> ((ab >*< x) >/< interpret 2) >^< interpret 3 <! Misconception Volume Area <! Other "M5"++pTaskQ1 :: InterpretationParser (Approach,[Step])+pTaskQ1 = (Algebraic,) <$> many' (pSomewhere $+           pNamedStep (newId "Q1.S1") (interpret $ wildcard "abc") abc+        |> withModulo nf (pNamedStep (newId "Q1.S1") (interpret $ wildcard "abc") (first sqrt <$> (interpret 10 >^< interpret 2 >+< x >^< interpret 2)))+          )+        |> (Arithmetic,) <$> pQ3Arithmetic++bf :: Interpretation+bf = interpret 2 <|> interpret (Var "bf")++cd :: Interpretation+cd = interpret 3 <|> interpret (Var "cd")++bdef :: Interpretation+bdef = bf >>*<< (x >>+<< cd)+   <|> bf >*< x >*< cd <! OperatorMixedUp plusSymbol timesSymbol <! Other "M3"+   <|> (bf >+< cd >+< x) >*< interpret 2 <! Misconception Perimeter Area <! Other "M4"+   <|> bf >+< cd >+< x <! Misconception HalfPerimeter Area <! Other "M5"+   <|> (interpret 5 >*< x <! IncorrectDistribution <! Other "M7")++pTaskQ2 :: InterpretationParser [Step]+pTaskQ2 = pAnyOf [pNamedStep (newId "Q2.S1") (interpret $ wildcard "bdef") bdef]++pTaskQ3 :: InterpretationParser (Approach, [Step])+pTaskQ3 = (,) Algebraic <$> pQ3Algebraic+       |> (,) Arithmetic <$> pQ3Arithmetic++pQ3Arithmetic :: InterpretationParser [Step]+pQ3Arithmetic = pAnyOf+                [ pStepEq (newId "Q3.A1") (interpret 5 >>*<< interpret (wildcard "x")) ((interpret 2 >*< interpret (wildcard "x")) >+< interpret 6)+                , pStepStrongIneq' (newId "Q3.A1") (interpret 5 >>*<< interpret (wildcard "x")) ((interpret 2 >*< interpret (wildcard "x")) >+< interpret 6)++                , pStepEq (newId "Q3.A2") (interpret 5 >>*<< interpret 2) ((interpret 2 >*< interpret 2) >+< interpret 6)+                , pStepStrongIneq' (newId "Q3.A2") (interpret 5 >>*<< interpret 2) ((interpret 2 >*< interpret 2) >+< interpret 6)++                , pNamedStep (newId "Q3.A3") (interpret $ wildcard "ans") (interpret 2)+                ]+                -- divide both sides by 10: 0.5x*10=2x+6 0.5x=0.2x+0.6 0.3x=0.6 x=2++pQ3Algebraic :: InterpretationParser [Step]+pQ3Algebraic = inLiberalEquationMode $ withModulo nfComAssoc $ pAnyOf+        [ pStepEq (newId "Q3.S1") (interpret 5 >>*<< x) (interpret 2 >>*<< x >>+<< (interpret 2 >>*<< interpret 3 <|> interpret 6))+        , pStepEq (newId "Q3.S2") (interpret 3 >>*<< x) (interpret 6)+        , pStepEq (newId "Q3.S3") x (interpret 2)+        ]+     |> (:[]) <$> pStepEq (newId "Q3.S1") abc bdef++class DiagnoseParser a where+  getApproach :: a -> Approach+  getSteps :: a -> [Step]++instance DiagnoseParser [Step] where+  getApproach _ = Algebraic+  getSteps = id++instance DiagnoseParser (Approach,[Step]) where+   getApproach (a, _) = a+   getSteps    (_, a) = a++pDiagnose :: DiagnoseParser a => InterpretationParser a -> InterpretationParser Diagnosis+pDiagnose p = do addWildcardConstraint "x" isLiteral+                 addWildcardConstraint "def" isVariable+                 z <- p+                 guard (not . Prelude.null . getSteps $ z)+                 return $ newDiagnosis (getApproach z) (getSteps z)
+ src/Task/CarRental.hs view
@@ -0,0 +1,200 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.CarRental (carRental) where++import Control.Applicative+import Control.Monad+import Control.Monad.State hiding (state)+import qualified Data.Map as M+import Data.Maybe+import Data.Semigroup hiding (option)+import Domain.Math.Data.MultivariatePolynomial+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Ideas.Common.Library hiding (option, (|>), steps, parser, recognizer)+import Ideas.Text.HTML+import Ideas.Text.XML hiding (Attribute)+import qualified Ideas.Text.XML as I (toXML)+import Recognize.Data.Approach (Approach (Algebraic, Arithmetic, Graphical))+import Recognize.Data.MathStoryProblem+import Recognize.Data.Attribute+import Recognize.Data.MathParserOptions+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Data.StringLexerOptions+import Recognize.Expr.Normalform+import Recognize.Data.Math+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.Parsing.Interpretation+import Recognize.Recognizer+import Util.Expr+import Bayes.Evidence+import Recognize.Data.Step+import Task.Network.CarRental++carRental :: MathStoryProblem+carRental = mathStoryProblem+   { problemId   = newId "carrental"+   , analyzers   = [(newId "03", ana)]+   , inputFile   = Just "input/carrental.csv"+   , networkFile = Just "networks/CarRental.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { lexer      = stringLexer stringLexerOptions {variableWhitelist = ["distance","dist","cost","afstand","kosten","prijs","éloignement","coût","km"]}+      , parser     = mathParser mathParserOptions {multByConcatenation = False} . stringLexerOutput+      , recognizer = defaultRecognizer pDiagnosis . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False . myassess+      }++   myassess d = ans1Strat .== (if category d == Algebraic then "Algebraic" else "Numerical")+             <> ans1 .== any (\x -> let atts = snd (getValue x)+                                                            in elem Normalized atts+                                                            && getId x `elem` finalSteps+                                                            && not (any (liftM2 (||) isMistake isApproximation) atts)) (steps d)+             <> mconcat (map assessStep (steps d))+                              {-++ [Evidence { getEvName = "SolutionStepwise", evidence =+                                    if (any (`elem` (steps d)) (map newId ["area triangle","side small square","area small square"]))+                                    then 0+                                    else 1}]+                                    any (contains (=FinalStep, IsNormalized && no errors) steps d+                                    -}+finalSteps :: [Id]+finalSteps = map newId ["s6a","s9b","conclude"]++assessStep :: Step -> Evidence+assessStep s+   | getId s == newId "s3a" = ans1Strat1Step2  .== Just stepCorrect+   | getId s == newId "s4a" = ans1Strat1Step31 .== Just stepCorrect+   | getId s == newId "s5a" = ans1Strat1Step41 .== Just stepCorrect+   | getId s == newId "s6a" = ans1Strat1Step51 .== Just stepCorrect+   | getId s == newId "s7b" = ans1Strat1Step32 .== Just stepCorrect+   | getId s == newId "s8b" = ans1Strat1Step42 .== Just stepCorrect+   | getId s == newId "s9b" = ans1Strat1Step52 .== Just stepCorrect+   | getId s == newId "concludeEquation" = ans1Strat1Step6 .== Just stepCorrect+   | getId s == newId "concludeArithmetic" = ans1Strat2Step3 .== Just stepCorrect+   | getId s == newId "compute" || getId s == newId "relate"+     , Just n <- listToMaybe $ mapMaybe (\x -> case x of { CapturedWildcard _ i -> Just i; _ -> Nothing}) (snd (getValue s))+     , Just i <- match rationalView (simplify rationalView n)+     = let node | i == 92 = ans1Strat2Step2+                | otherwise = ans1Strat2Step1+       in node .== Just stepCorrect+   | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)+++-- | This is a datatype that is private to this module; used only to make the+-- parsers read a bit easier and minimize the changes needed to make the new+-- models work.+data AlgebraicApproach = ApproachEquation | ApproachInequality deriving (Eq)++pTaskS3a :: InterpretationParser Step+pTaskS3a =+ pNamedStep (newId "s3a") (interpret $ wildcard "c") $+      interpret (Number 20) >+< interpret (Number 0.25) >*< interpret (wildcard "d")+  <|> interpret (Number 20) >+< interpret (Number 0.25) >*< interpret (Number 43) <! Other "M1"++pTaskS4a :: AlgebraicApproach -> InterpretationParser Step+pTaskS4a approach = case approach of+   ApproachEquation -> pStepEq (newId "s4a") a b+   ApproachInequality -> pStepStrongIneq' (newId "s7b") b a+ where+  a = interpret (Number 20) >+< interpret (Number 0.25) >*< interpret (wildcard "d")+  b = interpret (Number 43)++pTaskS5a :: AlgebraicApproach -> InterpretationParser Step+pTaskS5a approach = case approach of+   ApproachEquation -> pStepEq (newId "s5a") a b+   ApproachInequality -> pStepStrongIneq' (newId "s8b") b a+ where+   a = (interpret (Number 0.25) >*< interpret (wildcard "d")) <|> interpret (Number 23)+   b = interpret (Number 43) >-< interpret (Number 20)++pTaskS6a :: AlgebraicApproach -> InterpretationParser Step+pTaskS6a approach = case approach of+   ApproachEquation -> pNamedStep (newId "s6a") a b+   ApproachInequality -> pStepStrongIneq' (newId "s9b") b a+ where+  a = interpret (wildcard "d")+  b =    interpret 4 >>*<< (interpret (Number 43) >-< interpret (Number 20))+    <|> (interpret (Number 43) >-< interpret (Number 20)   >*< interpret (Number 0.25)) <! Other "M2"+    <|> (interpret (Number 43) >*< interpret (Number 0.25) >-< interpret (Number 20))   <! Other "M3"+    <|> (interpret (Number 43) >-< interpret (Number 0.25) >-< interpret (Number 20))   <! Other "M4"++pEstimate :: InterpretationParser [Step]+pEstimate = do clearWildcard "i"+               clearWildcard "j"+               zs <- catMaybes <$> sequence+                [ option (pStepEq (newId "estimate") (interpret $ wildcard "d") (interpret (wildcard "i")))+                , Just <$> pSomewhere+                   (  pStepEq (newId "compute") (interpret (Number 20) >+< interpret (Number 0.25) >*< interpret (wildcard "i")) (interpret (wildcard "j"))+                   |> pStep (newId "compute") (interpret (Number 20) >+< interpret (Number 0.25) >*< interpret (wildcard "i"))+                   |> do (_, step) <- pStepIneq (newId "relate") (interpret (Number 20 + Number 0.25* wildcard "i") <|> interpret (wildcard "j")) (interpret (Number 43))+                         return step+                   )+                ]+               i <- getWildcard "i"+               let zs' = case i of+                          Just i' -> map (addAttribute (CapturedWildcard "i" i')) zs+                          _ -> zs+               j <- getWildcard "j"+               case j of+                 Just j' -> return (map (addAttribute (CapturedWildcard "j" j')) zs')+                 _ -> return zs'++pConclude :: Maybe AlgebraicApproach -> InterpretationParser [Step]+pConclude approach = pAnywhere (singleton <$> pNamedStep (newId label) (interpret $ wildcard "d")+             (   interpret (Number 92)+             <|> (interpret (wildcard "n") <|> interpret (wildcard "n") >*< interpret (Var "km")) <! Approximation+             )+            )+   where+   label = case approach of+      Just _ -> "concludeEquation"+      Nothing -> "concludeArithmetic"+      -- -- | approach == Just ApproachInequality = "concludeInequality"+      -- -- | approach == Nothing = "concludeArithmetic"++pArithmetic :: InterpretationParser [Step]+pArithmetic = ((\x -> maybe x (\y -> x ++ y)) . concat <$> many1' (pSomewhere pEstimate)) <*> option (pConclude Nothing)++pAlgebraic :: AlgebraicApproach -> InterpretationParser [Step]+pAlgebraic approach = (\x -> maybe x (\y -> x ++ y)) <$> nonEmpty (catMaybes <$> many' (choice'+        [ Just <$> pTaskS3a+        , Just <$> pTaskS4a approach+        , Just <$> pTaskS5a approach+        , Just <$> pTaskS6a approach+        , Nothing <$ skip+        ])) <*> (option $ pConclude (Just approach))++pTask :: InterpretationParser (Approach,[Step])+pTask = (,) Algebraic <$> pAlgebraic ApproachEquation+    <|> (,) Algebraic <$> pAlgebraic ApproachInequality+    <|> (,) Arithmetic <$> pArithmetic++pDiagnosis :: InterpretationParser Diagnosis+pDiagnosis = do addWildcardConstraint "d" isVariable+                addWildcardConstraint "c" isVariable+                addWildcardConstraint "i" isLiteral+                addWildcardConstraint "j" isLiteral+                addWildcardConstraint "n" (\n -> case match rationalView (simplify rationalView n) of+                                                  Just d -> isLiteral n && abs (d - 92) < 20+                                                  _ -> False)+                (c,st) <- withModulo (restoreWildcards . simplify (multivariatePolynomialViewWith (doubleRoundedView (roundDouble 2))) . wildcardsToVars) pTask+                state <- get+                return (newDiagnosis c st)+                --Previous versions logged "getMatchEnvironment state", might be useful for debugging.
+ src/Task/MagicTrick/Assess.hs view
@@ -0,0 +1,279 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Assessment for the magictrick exercise
+--
+-----------------------------------------------------------------------------
+
+module Task.MagicTrick.Assess where
+
+import Data.Monoid
+import qualified Data.List.NonEmpty as N
+import qualified Data.Semigroup as SG
+import Domain.Math.Expr
+import Ideas.Common.Id hiding ((<>))
+import Recognize.Data.Approach
+import Recognize.Data.Attribute
+import Bayes.Evidence
+import Recognize.Data.Op
+import Recognize.Data.RuleId
+import Recognize.Data.Diagnosis as S
+import Recognize.Data.Step
+import Recognize.Model.Assess
+import Recognize.Model.Connectives
+import Recognize.Model.Constraint
+import Recognize.Model.EvidenceBuilder
+import Recognize.Expr.Symbols
+import Task.Network.MagicTrick
+import Bayes.Network
+
+assess' :: Diagnosis -> Evidence
+assess' sd =
+  --stringNode (apprtostring appr) ans1Strat <> --check which approach has been used
+  generateEvidence (`buildStepsEvidence` me) appr attrs
+  where
+    -- sd = firstDiagnosis md
+    attrs = map (snd . getValue) $ steps sd
+    me = payload sd --Get the magic expression
+    appr = approach sd
+
+-- Unnecessary to verify arithmetic strategy constraints when the category is algebraic and vice versa.
+buildStepsEvidence :: Approach -> Maybe Expr -> EvBuilder ()
+buildStepsEvidence Algebraic (Just me) = stepsA1Builder me SG.<> stepsA2Builder me
+buildStepsEvidence Numerical (Just me) = stepsN1Builder me SG.<> stepsN2Builder me
+buildStepsEvidence _ Nothing           = return ()
+
+add8C :: Constraint EvBuilder [Attribute]
+add8C = exists1 (Expand $ Add 8)
+mul3C :: Constraint EvBuilder [Attribute]
+mul3C = exists1 (Expand $ Mul 3)
+sub4C :: Constraint EvBuilder [Attribute]
+sub4C = exists1 (Expand $ Sub 4)
+addXC :: Expr -> Constraint EvBuilder [Attribute]
+addXC x = exists1 (Expand $ Add x)
+div4C :: Constraint EvBuilder [Attribute]
+div4C = exists1 (Expand $ Div 4)
+add2C :: Constraint EvBuilder [Attribute]
+add2C = exists1 (Expand $ Add 2)
+subXC :: Expr -> Constraint EvBuilder [Attribute]
+subXC x = exists1 (Expand $ Sub x)
+
+fullyExpanded :: Expr -> Constraint EvBuilder [Attribute]
+fullyExpanded x = mconcat [add8C, mul3C, sub4C, addXC x, div4C, add2C, subXC x]
+
+stepsA1Builder :: Expr -> EvBuilder ()
+stepsA1Builder me = do
+  -- For all steps in the general strategy the formula must first be fully expanded
+  let fullC = fullyExpanded me
+  giveNodeAndCollect ans1Strat1Step2 (fullC <> (fullC ==> failOnAnyMistake))
+
+  -- We introduce a variable that will match to anything
+  a1_2 <- newVar "a1_2"
+  giveNodeAndCollect ans1Strat1Step3 (fullC ==> implication
+              -- The only difference between the hypothesis and the conclusion is @a1_2@ and @24@. Since @a1_2@ will match to anything
+              -- if it matches to something that is not @24@ then a failure is generated. Otherwise, either we get a success or unknown.
+              [ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + a1_2) -- must be nat
+              ]
+              [ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + 24) ])
+
+  a1_3 <- newVar "a1_3"
+  giveNodeAndCollect ans1Strat1Step4 (fullC ==> implication
+              -- By now we should have an actual value for @a1_2@, but we repeat the same process that we used in the above constraint
+              [ ARule Collect_Num (a1_2 N.:| [-4]) a1_3
+              , ARule Collect_Var (3*me N.:| [me]) (4*me)
+              ]
+              -- normalform will simplify @a1_2 - 4@ within the comparison function
+              [ ARule Collect_Num (a1_2 N.:| [-4]) (normalform $ a1_2 - 4)
+              , ARule Collect_Var (3*me N.:| [me]) (4*me) ])
+
+  a1_4 <- newVar "a1_4"
+  giveNodeAndCollect ans1Strat1Step5 $ fullC ==> implication
+              [ ARule Distr_Division (((4*me + a1_3) / 4) N.:| []) ((4*me)/4 + a1_3/4)
+              , ARule Division (4*me/4 N.:| []) me
+              , ARule Division (a1_3/4 N.:| []) a1_4
+              ]
+              [ ARule Distr_Division (((4*me + a1_3) / 4) N.:| []) ((4*me)/4 + a1_3/4)
+              , ARule Division (4*me/4 N.:| []) me
+              , ARule Division (a1_3/4 N.:| []) (normalform $ a1_3 / 4)]
+
+  giveNodeAndCollect ans1Strat1Step6 $ fullC ==> implication
+              [ ARule Collect_Var (me N.:| [- me]) 0
+              , ARule Collect_Num (a1_4 N.:| [2]) (normalform $ a1_4 + 2)
+              ]
+              []
+
+  giveNodeAndCollect ans1 $ fullC ==> implication
+              [ ARule Collect_Var (me N.:| [- me]) 0
+              , ARule Collect_Num (a1_4 N.:| [2]) (normalform $ a1_4 + 2)
+              ]
+              []
+
+stepsA2Builder :: Expr -> EvBuilder ()
+stepsA2Builder me = do
+  giveNodeAndCollect ans1Strat2Step1 add8C
+
+  a2_2 <- newVar "a2_2"
+  -- For stepwise strategies we only require expansion of the formula up to a certain point
+  -- If we could not verify constraint a2_2 then it must mean @a2_2@ still refers to some wildcard. With collectDefault @a2_2@ will be a2_signed 24
+  -- if the result of constraint @a2_2@ is unknown
+  giveNodeAndCollectDefault ans1Strat2Step2 (add8C ==> mul3C ==> (implication
+              [ ARule Distr_Times ((me + 8)*3 N.:| []) (3*me + a2_2) ]
+              [ ARule Distr_Times ((me + 8)*3 N.:| []) (3*me + 24)
+              ]
+              <?>> failOnAnyMistake))
+              a2_2 24
+
+  -- With collectDefault @a2_3@ will be assigned @a2_2 - 4@ if the result of constraint @a2_3@ is unknown.
+  a2_3 <- newVar "a2_3"
+  giveNodeAndCollectDefault ans1Strat2Step3 (sub4C ==> (implication
+              [ ARule Collect_Num (a2_2 N.:| [-4]) a2_3 ]
+              [ ARule Collect_Num (a2_2 N.:| [-4]) (normalform $ a2_2 - 4) ]
+              <?>> failOnAnyMistake))
+              a2_3 (normalform $ a2_2 - 4)
+
+  giveNodeAndCollect ans1Strat2Step4 $ addXC me ==> (implication
+                [ ARule Collect_Var (3*me N.:| [me]) (4*me)]
+                [ ARule Collect_Var (3*me N.:| [me]) (4*me) ]
+                <?>> failOnAnyMistake)
+
+  -- With collectDefault @a2_5@ will be assigned @a2_3 / 4@ if the result of constraint @a2_5@ is unknown.
+  a2_5 <- newVar "a2_5"
+  giveNodeAndCollectDefault ans1Strat2Step5 (div4C ==> (implication
+              [ ARule Distr_Division (((4*me + a2_3) / 4) N.:| []) ((4*me)/4 + a2_3/4)
+              , ARule Division (4*me/4 N.:| []) me
+              , ARule Division (a2_3/4 N.:| []) a2_5
+              ]
+              [ ARule Distr_Division (((4*me + a2_3) / 4) N.:| []) ((4*me)/4 + a2_3/4)
+              , ARule Division (4*me/4 N.:| []) me
+              , ARule Division (a2_3/4 N.:| []) (normalform $ a2_3 / 4)]
+              <?>> failOnAnyMistake))
+              a2_5 (normalform $ a2_3 / 4)
+
+  a2_6 <- newVar "a2_6"
+  giveNodeAndCollectDefault ans1Strat2Step6 (add2C ==> (implication
+              [ ARule Collect_Num (a2_5 N.:| [2]) a2_6 ]
+              [ ARule Collect_Num (a2_5 N.:| [2]) (normalform $ a2_5 + 2) ]
+              <?>> failOnAnyMistake))
+              a2_6 (normalform $ a2_5 + 2)
+
+  a2_7 <- newVar "a2_7"
+  giveNodeAndCollect ans1Strat2Step7 $ subXC me ==> (implication
+              [ ARule Collect_Var (me N.:| [-me]) 0 ]
+              []
+              <?>> failOnAnyMistake)
+
+  giveNodeAndCollect ans1 $ subXC me ==> (implication
+              [ ARule Collect_Var (me N.:| [-me]) 0 ]
+              []
+              <?>> failOnAnyMistake)
+
+stepsN1Builder :: Expr -> EvBuilder ()
+stepsN1Builder me = do
+  let fullC = fullyExpanded me
+  giveNodeAndCollect ans1Strat3Step1 $ fullC ==> failOnAnyMistake
+
+  --Create an empty node to hold the intermediate steps
+
+  let empty = Node "empty" "" [("Correct", True),("Incorrect", False)] [] (CPT [0.5, 0.5])
+
+  n1_2 <- newVar "n1_2"
+  giveNodeAndCollect empty $ fullC ==> (implication
+              [ ARule Collect_Num (me N.:| [8]) n1_2 ]
+              [ ARule Collect_Num (me N.:| [8]) (normalform $ me + 8) ]
+              <?>> failOnAnyMistake)
+
+  n1_3 <- newVar "n1_3"
+  giveNodeAndCollect empty $ fullC ==> (implication
+              [ ARule Times (n1_2 N.:| [3]) n1_3 ]
+              [ ARule Times (n1_2 N.:| [3]) (normalform $ n1_2 * 3) ]
+              <?>> failOnAnyMistake)
+
+  n1_4 <- newVar "n1_4"
+  giveNodeAndCollect empty $ fullC ==> (implication
+              [ ARule Collect_Num (n1_3 N.:| [-4, me]) n1_4 ]
+              [ ARule Collect_Num (n1_3 N.:| [-4, me]) (normalform $ n1_3 - 4 + me) ]
+              <?>> failOnAnyMistake)
+
+  n1_5 <- newVar "n1_5"
+  giveNodeAndCollect empty $ fullC ==> (implication
+              [ ARule Division (n1_4 N.:| [4]) n1_5 ]
+              [ ARule Division (n1_4 N.:| [4]) (normalform $ n1_4 / 4) ]
+              <?>> failOnAnyMistake)
+
+  n1_6 <- newVar "n1_6"
+  giveNodeAndCollect ans1Strat3Step2 $ fullC ==> (implication
+              [ ARule Collect_Num (n1_5 N.:| [2, me]) n1_6 ]
+              [ ARule Collect_Num (n1_5 N.:| [2, me]) (normalform $ n1_5 + 2 - me) ]
+              <?>> failOnAnyMistake)
+
+  giveNodeAndCollect ans1 $ fullC ==> (implication
+              [ ARule Collect_Num (n1_5 N.:| [2, me]) n1_6 ]
+              [ ARule Collect_Num (n1_5 N.:| [2, me]) (normalform $ n1_5 + 2 - me) ]
+              <?>> failOnAnyMistake)
+
+stepsN2Builder :: Expr -> EvBuilder ()
+stepsN2Builder me = do
+  n2_1 <- newVar "n2_1"
+  let cn2_1a = add8C
+      cn2_1b = implication
+                [ ARule Collect_Num (me N.:| [8]) n2_1 ]
+                [ ARule Collect_Num (me N.:| [8]) (normalform $ me + 8) ]
+              <?>> failOnAnyMistake
+  if me == 0
+    then setValueOf n2_1 8 >> giveNodeAndCollect ans1Strat4Step1 cn2_1a
+    else giveNodeAndCollectDefault ans1Strat4Step1 (add8C ==> cn2_1b) n2_1 (normalform $ me + 8)
+
+  n2_2 <- newVar "n2_2"
+  giveNodeAndCollectDefault ans1Strat4Step2 (mul3C ==> (implication
+              [ ARule Times (n2_1 * 3 N.:| []) n2_2 ]
+              [ ARule Times (n2_1 * 3 N.:| []) (normalform $ n2_1 * 3) ]
+              <?>> failOnAnyMistake))
+              n2_2 (normalform $ n2_1 * 3)
+
+  n2_3 <- newVar "n2_3"
+  giveNodeAndCollectDefault ans1Strat4Step3 (sub4C ==> (implication
+              [ ARule Collect_Num (n2_2 N.:| [-4]) n2_3 ]
+              [ ARule Collect_Num (n2_2 N.:| [-4]) (normalform $ n2_2 - 4) ]
+              <?>> failOnAnyMistake))
+              n2_3 (normalform $ n2_2 - 4)
+
+  n2_4 <- newVar "n2_4"
+  giveNodeAndCollectDefault ans1Strat4Step4 (addXC me ==> (implication
+              [ ARule Collect_Num (n2_3 N.:| [me]) n2_4 ]
+              [ ARule Collect_Num (n2_3 N.:| [me]) (normalform $ n2_3 + me) ]
+              <?>> failOnAnyMistake))
+              n2_4 (normalform $ n2_3 + me)
+
+  n2_5 <- newVar "n2_5"
+  giveNodeAndCollectDefault ans1Strat4Step5 (div4C ==> (implication
+              [ ARule Division (n2_4 / 4 N.:| []) n2_5 ]
+              [ ARule Division (n2_4 / 4 N.:| []) (normalform $ n2_4 / 4) ]
+              <?>> failOnAnyMistake))
+              n2_5 (normalform $ n2_4 / 4)
+
+  n2_6 <- newVar "n2_6"
+  giveNodeAndCollectDefault ans1Strat4Step6 (add2C ==> (implication
+              [ ARule Collect_Num (n2_5 N.:| [2]) n2_6 ]
+              [ ARule Collect_Num (n2_5 N.:| [2]) (normalform $ n2_5 + 2) ]
+              <?>> failOnAnyMistake))
+              n2_6 (normalform $ n2_5 + 2)
+
+  n2_7 <- newVar "n2_7"
+  giveNodeAndCollect ans1Strat4Step7 $ subXC me ==> (implication
+              [ ARule Collect_Num (n2_6 N.:| [-me]) n2_7
+              ]
+              [ ARule Collect_Num (n2_6 N.:| [-me]) (normalform $ n2_6 - me) ]
+              <?>> failOnAnyMistake)
+
+  giveNodeAndCollect ans1 $ subXC me ==> (implication
+              [ ARule Collect_Num (n2_6 N.:| [-me]) n2_7
+              ]
+              [ ARule Collect_Num (n2_6 N.:| [-me]) (normalform $ n2_6 - me) ]
+              <?>> failOnAnyMistake)
+ src/Task/MagicTrick/Recognizer.hs view
@@ -0,0 +1,715 @@+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Here we implemented the diagnosis for the magictrick exercise+--+-----------------------------------------------------------------------------++module Task.MagicTrick.Recognizer where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.List+import qualified Data.List.NonEmpty as N+import Data.Maybe+import Domain.Math.Data.Relation+import Domain.Math.Expr hiding (pExpr, fromDouble)+import Ideas.Common.Id+import Ideas.Utils.Uniplate+import Recognize.Data.Approach+import Recognize.Data.Attribute+import Recognize.Data.Math+import Recognize.Data.Op+import Recognize.Data.Diagnosis+import Recognize.Data.Step+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Parsing.Parse+import Recognize.Parsing.Derived+import Recognize.Parsing.MathParser      (parseMath)+import Recognize.Data.MathParserOptions+import Recognize.Strategy.Applications+import Recognize.SubExpr.SEParser+import Util.List+import Recognize.Data.MathStoryProblem+import Recognize.Data.MathParserOutput+import Recognize.Recognizer+import Task.MagicTrick.Assess+import Task.Network.MagicTrick+import Bayes.Probability ( fromDouble, Probability )+import Bayes.Network ( Node(..) )+import Bayes.Evidence ( Evidence, evidenceOfAbsence, nodeNotSet, nodeIsSet, nodeSetTo, (.=~) )++magicTrick :: MathStoryProblem+magicTrick = mathStoryProblem+   { problemId   = newId "magictrick"+   , analyzers   = [(newId "05", ana)]+   , inputFile   = Just "input/magictrick.csv"+   , networkFile = Just "networks/MagicTrick.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { recognizer = myrecognize+      , collector  = fillInMissedSteps . evidenceOfAbsence ans1 False . whereDidWeGoWrong . assess'+      }+   myrecognize po = seRecognizer pDiagnosis $ mathParserOutput po+++{-+This module contains some postprocessing steps as a compromise to address a+number of issues we currently have:++1. There is an overwhelming bias toward positive rather than negative evidence.+2. There is not enough evidence in general, because the domain reasoner+allegedly produces evidence that is too shallow for the Bayesian networks to+work with. That is, it does not make "deep" judgments, like drawing conclusions+from steps that the student has skipped, or inferring that steps have been+taken from contextual clues.++Ideally, these problems would be solved by changing the way that the domain+reasoner works. However, that is infeasible in the current timeframe. Instead,+we will made judgment like these in a more ad-hoc manner: by transforming the+evidence, adding soft positive and negative evidence based on the hard, mostly+positive evidence found earlier.+-}++probHigh, probMediumLow, probLow :: [Probability]+probHigh = [fromDouble 0.8, fromDouble 0.2, fromDouble 0]+probMediumLow = [fromDouble 0.4, fromDouble 0.6, fromDouble 0]+probLow = [fromDouble 0.2, fromDouble 0.8, fromDouble 0]++-- | Postprocessing step on the found evidence: When there is no final answer,+-- but there are intermediate steps, we boldly assume that the step after the last+-- intermediate step was the culprit and we set its evidence to negative. If+-- there were no intermediate steps, we set the first step of each strategy to+-- negative.+whereDidWeGoWrong :: Evidence -> Evidence+whereDidWeGoWrong ev =+   if nodeIsSet ans1 ev+   then ev+   else mappend ev . additionalEvidence . flip map [strat1,strat2,strat3,strat4] $ \strat ->+      if studentTried strat ev+      then whereDidItGoWrong strat+      else Nothing++   where++   additionalEvidence nodes = mconcat $ case catMaybes nodes of+      [] -> map (.=~ probMediumLow) [ans1Strat1Step1, ans1Strat2Step1, ans1Strat3Step1, ans1Strat4Step1]+      other -> map (.=~ probLow) other++   studentTried :: [Node a] -> Evidence -> Bool+   studentTried strat ev' = any (flip nodeIsSet ev') strat ++   whereDidItGoWrong :: [Node a] -> Maybe (Node a)+   whereDidItGoWrong strat = listToMaybe . reverse . takeWhile (flip nodeNotSet ev) . reverse $ strat++   strat1 = [ans1Strat1Step1, ans1Strat1Step2, ans1Strat1Step3, ans1Strat1Step4, ans1Strat1Step5, ans1Strat1Step6]+   strat2 = [ans1Strat2Step1, ans1Strat2Step2, ans1Strat2Step3, ans1Strat2Step4, ans1Strat2Step5, ans1Strat2Step6, ans1Strat2Step7]+   strat3 = [ans1Strat3Step1, ans1Strat3Step2]+   strat4 = [ans1Strat4Step1, ans1Strat4Step2, ans1Strat4Step3, ans1Strat4Step4, ans1Strat4Step5, ans1Strat4Step6, ans1Strat4Step7]+++-- | Postprocessing steps on the found evidence. +-- When all the nodes on the LHS are present in the evidence but none on the+-- RHS are, we set evidence to the nodes on the RHS. Note that it is evaluated+-- left-to-right, so later steps should appear first. +fillInMissedSteps :: Evidence -> Evidence+fillInMissedSteps = applyTransformations+   [+   -- Every next step implies the previous step+      ( nodeSetTo ans1Strat1Step6 (Just True)+      , ans1Strat1Step5 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat1Step5 (Just True)+      , ans1Strat1Step4 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat1Step4 (Just True)+      , ans1Strat1Step3 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat1Step3 (Just True)+      , ans1Strat1Step2 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat1Step2 (Just True)+      , ans1Strat1Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step7 (Just True)+      , ans1Strat2Step6 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step6 (Just True)+      , ans1Strat2Step5 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step5 (Just True)+      , ans1Strat2Step4 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step4 (Just True)+      , ans1Strat2Step3 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step3 (Just True)+      , ans1Strat2Step2 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step2 (Just True)+      , ans1Strat2Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat3Step2 (Just True)+      , ans1Strat3Step1 .=~ probHigh )++   -- Choose variable is implied by every later step+   ,  ( nodeSetTo ans1Strat1Step3 (Just True)+      , ans1Strat1Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat1Step4 (Just True)+      , ans1Strat1Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step3 (Just True)+      , ans1Strat2Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step5 (Just True)+      , ans1Strat2Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step6 (Just True)+      , ans1Strat2Step1 .=~ probHigh )+   ,  ( nodeSetTo ans1Strat2Step7 (Just True)+      , ans1Strat2Step1 .=~ probHigh )+   ]++   where+   applyTransformations :: [(Evidence -> Bool, Evidence)] -> Evidence -> Evidence+   applyTransformations = flip $ foldl (flip applyTransformation)++   applyTransformation :: (Evidence -> Bool, Evidence) -> Evidence -> Evidence+   applyTransformation (ante, post) ev = +      case ante ev of+         True -> ev `mappend` post+         False -> ev++++pDiagnosis :: SEParser Diagnosis+pDiagnosis = do+  sds <- pAttempts1+  -- TODO: Should perhaps also move the first algebraic attempt to the front+  return $ head sds++--Option that defines if we can take many buggy pars or only one+oTryManyBuggyPars :: Bool+oTryManyBuggyPars = True++--Option that defines if we can skip expressions+oSkipExpressions :: Bool+oSkipExpressions = True++-- wrapper around pAttempts; to only parse succesfull when at least one diagnosis has been matched.+pAttempts1 :: SEParser [Diagnosis]+pAttempts1 = do+  xs <- pAttempts+  when (null xs) empty+  return xs++-- | Tries to parse many attempts. If one fails then skip one input and try again until no input is left.+pAttempts :: SEParser [Diagnosis]                                 -- /--- a |> approach here, will cause Correct;garbage;garbage to process all possible fix first+pAttempts+  | oSkipExpressions = catMaybes <$> many (Just <$> pStdDiagnosis <|> Nothing <$ skip)+  | otherwise = many1 pStdDiagnosis++guessMagicExpr :: [Expr] -> [Expr]+guessMagicExpr [] = []+guessMagicExpr es@(e:_) = filter (matches es) z+   where+     z = nub $ [ x | Nat 8 :+: x <- universe e] -- niet efficient; maar willen prioriteit geven aan dit getal.+                              ++ [ x | x :+: Nat 8 <- universe e ] -- ,,+                              ++ concatMap f (universe e)+                              ++ [Nat 0]+     f v@(Nat _) = [v]+     f v@(Var _) = [v]+     f v@(Negate (Nat _)) = [v]+     f v@(Number _) = [v]+  -- function call+     f _ = []+     -- Tests whether the guessed magic expression is the actual magic expression+     -- we do this by looking for an expression of the form 8 + x or x + 8. The magic expression+     -- should then equal x. As a special case for x == 0, we also check for 8 * 3 and 3 * 8, in which+     -- case 0 is implicitly added to 8.+     -- Note that we only test against the first 3 following expressions. This is for 3 reasons:+     -- 1. Performance+     -- 2. Avoid overlapping with other attempts+     -- 3. Sometimes irrelevant expressions may be present+     matches es' m = all (all (\e' -> case e' of+       Nat 8 :+: x -> m == x+       x :+: Nat 8 -> m == x+       _ -> True) . universe) (take 3 es')++pMagicExpr :: SEParser Expr+pMagicExpr = withInputList (guessMagicExpr . mapMaybe getExpr)++pVars :: SEParser [String]+pVars = withInput (nub . concatMap vars . mapMaybe getExpr)++pAnnounce :: [String] -> Expr -> SEParser ()+pAnnounce vs x = () <$ many (() <$ pExpr x+                         <|> choice [ pEq $ Var v :==: x | v <-  vs ] )++pConclude :: [String] -> [Expr] -> Expr -> SEParser Expr+pConclude vs cs r =+    maybe r fst . uncons <$>+        many (choice ((7 <$ pExpr 7) : [ c <$ pEq (Var v :==: c) | v <- vs, c <- cs ]))++-- | Main diagnosis function.+--+-- First we guess some magic expression and then try to recognize the formula+pStdDiagnosis :: SEParser Diagnosis+pStdDiagnosis = do+  x <- pMagicExpr+  vs <- pVars+  -- pAnnounce vs x+  (a,st) <- pStepsFor x x (if x == 0 then taskIfZero else task x)++  res <- pConclude vs (nub [x,a]) a+  let attrs = map getAttributes st+  return Diagnosis+    { category = case x of { (Var _) -> Algebraic ; _ -> Numerical }+    , correctResult = res == 7 -- result is correct+    , resultIsSimplified = nf res == res -- nf result == result+    , parenthesisMismatch = any (elem NonMatchingParentheses) attrs+    , payload = Just x --The magic expression+    , steps = st+    , result = Just res+    }++task :: Expr -> [Op]+task me = [Add 8, Mul 3, Sub 4, Add me, Div 4, Add 2, Sub me]++taskIfZero :: [Op]+taskIfZero = [Add 8, Mul 3, Sub 4, Div 4, Add 2]++expandOps :: [Op] -> [Attribute]+expandOps = map Expand++taskExpand :: Expr -> [Attribute]+taskExpand = map Expand . task++taskForget :: Expr -> [Attribute]+taskForget = map Forget . task++-- | Pipeline for recognition+--+-- The pipeline consists of 4 phases:+--+-- * Parse correct steps+-- * Parse a simplification step+-- * Forget a step+-- * A mistake was made. Try fixing the step+--+-- These phases are passed through linearly, but a phase may go back to phase 1 before reaching the latter phases.+pStepsFor :: Expr -> -- magic expression+             Expr -> -- current expression+             [Op] -> -- remaining ops+             SEParser (Expr, [Step])+pStepsFor x a ops = do+  pLog $ "pStepsFor: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops+  option $ satisfyWith (getExpr >=> (\e -> guard (a == e)))+  -- Try to parse as many correct steps as possible+  eth <- pStepsPhase1 x a ops+  case eth of+    Left (e, st, ops') -> do+      pLog $ "Fail after phase1 " ++ show x ++ "  " ++ show st ++ "  " ++ show e ++ "  " ++ show ops'+      ms <- pStepsPhase2 x e+      case ms of+        Just (e', st') -> do+          pLog $ "success after phase2 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e'+          second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops'++        Nothing -> do+          pLog "Fail after phase 2"+          -- Forget one step+          ma <- pStepsPhase3 x e ops'+          case ma of+            Just (e', st', ops'') -> do+              pLog $ "success after phase3 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e' ++ "  " ++ show ops''+              -- After forgetting steps, we continue to try and parse correct steps+              second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops''++            Nothing -> do+              pLog $ "Failed phase3: " ++ show st ++ "  " ++ show e ++ "  " ++ show ops'+                -- If we could not continue by forgetting then we try fixing, if this also fails then the parsing fails+              (e', st', ops'') <- pStepsPhase4 x e ops' st+              pLog $ "success after phase4 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e' ++ "  " ++ show ops'+              second (\st'' -> st' ++ st'') <$> pStepsFor x e' ops''+    Right (e, st, _) -> do+      pLog $ "Success after phase1: " ++ show st ++ " | " ++ show e+      ms <- pStepsPhase2 x e+      case ms of+        Just (e', st') -> do+          pLog $ "success after phase2 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e'+          second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' []+        Nothing -> do+          pLog "done in StepsFor"+          return (e, st)++pStepsPhase1 :: Expr -> Expr -> [Op] -> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))+pStepsPhase1 = pTask pStepOperators++pStepsPhase2 :: Expr -> Expr -> SEParser (Maybe (Expr, Step))+pStepsPhase2 = pTaskSimplify++pStepsPhase3 :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))+pStepsPhase3 = pTaskErr++pStepsPhase4 :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])+pStepsPhase4 = pTaskForget++-- | Expands the current formula with a different number of operators.+--+-- Then attempts are made to recognize this formula.+pTask :: (Expr -> Expr -> [Op] -> SEParser (Expr, Step)) -- ^ to use recognition strategy+         -> Expr -- ^ magic expression+         -> Expr -- ^ current expression+         -> [Op] -- ^ remaining operators+         -> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))+pTask _ _ a [] = return $ Right (a, [], [])+pTask strat x a xs = do+  pLog $ "pTask: " ++ show x ++ " | " ++ show a ++ " | " ++ show xs+  pTask'+  where+    pTask' =+      choice'+              [ do+                (b, as)  <- strat x a ops+                eth <- pTask strat x b ys+                case eth of+                  Left (c, cs, zs) -> return $ Left (c, as : cs, zs)+                  Right (c, cs, zs) -> return $ Right (c, as : cs, zs)+              | (ops, ys) <- splits xs, length ops > 0+              ]+      |> pIf (null xs)  (succeed $ Right (a, [], xs))+      |> succeed (Left (a, [], xs))++-- | tries to match the current formula to some simplified form of that formula+pTaskSimplify :: Expr -> Expr -> SEParser (Maybe (Expr, Step))+pTaskSimplify x a = do+  pLog $ "pTaskSimplify: " ++ show x ++ " | " ++ show a+  m <- withInput head+  if fst (simplify a) == a then return Nothing+   else do+    ma <- option $ pStepSimplify x a+    return $ ma >>= \(e, as) -> Just (e, smallStep (newId "simplify") (m,as))++-- | It's possible some operation was forgotten to be added+pTaskForget :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])+pTaskForget x a [Sub ope] stps -- special case necessary for if the last operator has been forgotten+  | x == ope || (isVar x && isVar ope) = return (a, modifyAt (length stps - 1) (addAttribute (Forget $ Sub x)) stps, [])+  | otherwise = empty+pTaskForget x a (op:op2:xs) stps = do+  (e,st) <- pStepForget x a op op2+  return (e, stps++[st], xs)+pTaskForget _ _ _ _ = empty++-- | See if an error was made given the next operation+pTaskErr :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))+pTaskErr _ _ [] = empty+pTaskErr x a (op:xs) = option $ (\(e,st) -> (e,st,xs)) <$> pStepError x a [op]++pStepOperators :: Expr -- ^ magic expression+                -> Expr -- ^ the current expression+                -> [Op] -- ^ list of operators to be added+                -> SEParser (Expr, Step)+pStepOperators x a ops = do+  m <- withInput head+  (e,as) <- pStep x a ops+  let as' = map Expand ops ++ as+  return (e, smallStep (newId "") (m,as'))++pStepError :: Expr -- ^ magic expression+                -> Expr -- ^ the current expression+                -> [Op] -- ^ list of operators to be added+                -> SEParser (Expr, Step)+pStepError x a ops = do+  m <- withInput head+  (e,as) <- pStepErr x a ops+  return (e, smallStep (newId "") (m,as))++pStepForget :: Expr -- ^ magic expression+                -> Expr -- ^ the current expression+                -> Op -- ^ current step+                -> Op -- ^ next step+                -> SEParser (Expr, Step)+pStepForget x a op1 op2 = do+  m <- withInput head+  (e,as) <- pStep x a [op2]+  return (e, smallStep (newId "") (m,Forget op1 :as))++-- | Parse a step+--+-- Equation step, expression step or some erronuous step+pStep :: Expr -- ^ magic expression+      -> Expr -- ^ the current expression+      -> [Op] -- ^ list of operators to be added+      -> SEParser (Expr, [Attribute])+pStep x a ops =+  choice'+    [ do+      m <- peek+      guard $ isJust $ getEq m+      pStepEquation x a ops+    , do+      m <- peek+      guard $ isNothing $ getEq m+      pStepExpr x a ops+    , pBuggyStep x a ops+    ]++pStepErr :: Expr -> Expr -> [Op] -> SEParser (Expr, [Attribute])+pStepErr x a ops =+        -- pFixEqCom wil attempt to fix the equation to match the input+          pFixEqCom (b :==: b)+        |> choice [pFixEqCom (b :==: norm b) | norm <- [nfCom . nf]]+        |> pFixExprCom b+        |> choice [pFixExprCom (norm b) | norm <- [nfCom . nf]]+  where+    b = formExpr x a ops++pBuggyStep :: Expr -- ^ magic expression+           -> Expr -- ^ the current expression+           -> [Op] -- ^ list of operators to be added+           -> SEParser (Expr, [Attribute])+pBuggyStep x a ops =+  pIf (length ops >= 2) (+        ((,[IncorrectDistribution, Recovery])  . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b)+     |> ((,[IncorrectDistribution] ) . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b')+     |> (,[IncorrectDistribution]) <$> fst <$> pExprWith (\e -> (nfCom e,[])) b'+    )+  |> pIf (not $ null ops) (pNextStepBuggyPars a b)+ where+   b' = foldl (flip fromOp') a (map (substOp x) ops) -- b is a buggy parenthesis step+   b = formExpr x a ops++pStepSimplify :: Expr -- ^ magic expression+              -> Expr -- ^ the current expression+              -> SEParser (Expr, [Attribute])+pStepSimplify x a = do+  pLog $ "pStepSimplify: " ++ show x ++ " | " ++ show a+  choice'+    [ do+      m <- peek+      guard $ isJust $ getEq m+      (attr,e) <- pExplicitSimplifyEq x a+      return (attr,e)+    , do+      m <- peek+      guard $ isNothing $ getEq m+      (attr,e) <- pExplicitSimplifyExpr a+      return (attr,e)+    ]++pExplicitSimplifyEq :: Expr -- ^ magic expression+                    -> Expr -- ^ the current expression+                    -> SEParser (Expr, [Attribute])+pExplicitSimplifyEq x a = do+  pLog $ "pExplicitSimplifyEq: " ++ show x ++ " | " ++ show a+  choice+    [ first rightHandSide <$> pEqWith simplify (a :==: a)+    , pEqWithL simplify a+    ]++pExplicitSimplifyExpr :: Expr -- ^ the current expression+                      -> SEParser (Expr, [Attribute])+pExplicitSimplifyExpr = pExprWith simplify+++{-+((x+8)*3-4+x)/4+2-x = 7+(3x +24 - 4 + x)/4+2-x = 7+-}++{-+((x+8)*3-4+x)/4+2-x = (3x +24 - 4 + x)/4+2-x+(3x + 24 - 4 + x)/4+2-x = (4x+20)/4+2-x+-}+++pStepEquation :: Expr -- ^ magic expression+              -> Expr -- ^ the current expression+              -> [Op] -- ^ list of operators to be added+              -> SEParser (Expr, [Attribute])+pStepEquation x a ops = do+  pLog $ "pStepEquation: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops+  choice+    [ first rightHandSide <$> pEqWith simplify (b :==: b)+    , pEqWithL simplify b+    ]+  |> pIf (length ops <= 3)+        (pFixEqCom (b :==: nfCom (nf b)))+  where+    b = formExpr x a ops++-- | pStepExpr probeert een expressie te parsen+-- probeer eerst zonder normaliseren (maar modulo comm/assoc/distr)+-- probeer dan met normaliseren (dan telt de stap/berekening als impliciet)+-- probeer dan met fout correctie.+pStepExpr :: Expr -- ^ magic expression+          -> Expr -- ^ the current expression+          -> [Op] -- ^ list of operators to be added+          -> SEParser (Expr, [Attribute])+pStepExpr x a ops = do+  pLog $ "In pStepExpr: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops ++ " | " ++ show b+  pExprWith (\e -> (nfCom e, [])) b+  -- Be careful that you don't relax this condition too much. Otherwise any occurence of 7 can be seen as a fully expanded and simplified expression+  |> pIf (length ops < 4) (second (\attr -> (Implicit <$> ops)++attr) <$> pExprWith simplify b)+  where+    b = formExpr x a ops++pNextStepBuggyPars :: Expr -> Expr -> SEParser (Expr, [Attribute])+pNextStepBuggyPars _ b = let np = noPars b in choice'+   [ (lhs', [NonMatchingParentheses]) <$ pEqCom (lhs' :==: nf b)+     |> (lhs', [NonMatchingParentheses])  <$ pExprCom lhs'+     | lhs' <- np+   ]++splits :: [a] -> [([a], [a])]+splits xs = zip (inits xs) (tails xs)++pIf :: Alternative f => Bool -> f a -> f a+pIf b p = if b then p else empty++-- quick and dirty+noPars :: Expr -> [Expr]+noPars e = (if oTryManyBuggyPars then id else take 1) $ -- use take 1 to speed up the recognizer+            mapMaybe f (dropParensString (show e))+  where+    f s = case myparseExpr s of+      Just new | new /= e -> Just new+      _ -> Nothing++    myparseExpr s =+      case mapMaybe getExpr (snd $ parseMath mathParserOptions s) of+          [m] -> Just m+          _ -> Nothing+++-- drop sets of corresponding parentheses+dropParensString :: String -> [String]+dropParensString = rec []+  where+    rec ps [] = [ "" | null ps ]+    rec ps (x:xs)+      | x == '('  = rec (False:ps) xs ++ map (x:) (rec (True:ps) xs)+      | x == ')'  = if null ps+                    then []+                    else if head ps+                          then map (x:) (rec (drop 1 ps) xs)+                          else rec (drop 1 ps) xs+      | otherwise = map (x:) (rec ps xs)++pFixEqCom :: Equation Expr -- ^ expected+          -> SEParser (Expr, [Attribute])+pFixEqCom e = peekEq >>= \eq -> pLog ("pFixEqCom: " ++ show e ++ " | " ++ show eq) >> pMatchEq e eq++pMatchEq :: Equation Expr -- ^ expected+         -> Equation Expr -- ^ provided+         -> SEParser (Expr, [Attribute])+pMatchEq (a :==: b) (x :==: y) =+      pIf (not (a === x) && any (=== x) (changeOp a) && y === x)+        (pRewrite (y, [OperatorMixedUp plusSymbol plusSymbol]))+  <|> pIf (a /= x) (pMatchExpr a x)+  <|> pIf (not (a === x) && b === y) (second (Recovery:) <$> pMatchExpr (nfCom a) (nfCom x))+  <|> pIf (not (a === x) && b == y) (pRewrite (y, [InvalidEquation x y, Recovery]))+  <|> pIf (a === x && (b /= y)) (pRewrite (y, [InvalidEquation x y]))++pFixExprCom :: Expr -> SEParser (Expr, [Attribute])+pFixExprCom e = peekExpr >>= pMatchExpr e++pMatchExpr :: Expr -- ^ expected+           -> Expr -- ^ provided+           -> SEParser (Expr, [Attribute])+pMatchExpr e p = choice+  [ do+    el <- maybeToParse $ getLeft e+    pl <- maybeToParse $ getLeft p+    let e' = replaceLeft pl e+    guard (e' == p)+    pRewrite (p, [AtomMixedUp pl el])+  , do+    er <- maybeToParse $ getRight e+    pr <- maybeToParse $ getRight p+    let e' = replaceRight pr e+    guard (e' == p)+    pRewrite (p, [AtomMixedUp pr er])+  , pIf (equivalentStructure e p+          && filter isAtom (universe e) == filter isAtom (universe p)+          && not (isAtom e)+         )+      (pRewrite (p, [OperatorMixedUp plusSymbol plusSymbol]))+  , pIf ((not.isAtom) e+          && equivalentStructure e p+          && length (changeSet e p) == 1+         )+      (pRewrite (p, [AtomMixedUp p e]))+  ]++pEqWith :: (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])+pEqWith f x = do+  m <- satisfyWith Just+  pLog $ "pEqWith: " ++ show x ++ " | " ++ show m+  case getEq m of+    Just y -> do+      let xl = leftHandSide x+          yl = leftHandSide y+          (fxl,axl) = f xl+          (fxr,_)   = f (rightHandSide x)+          (fyl,ayl) = f yl+          (fyr,ayr) = f (rightHandSide y)+      guard (+        if xl == yl then fyl == fyr+                    else fxl == fyl && fyl == fyr && hasCommonality axl ayl && (hasCommonality ayl ayr || null ayr))+      pLog $ "pEqWith success: " ++ show fxl ++ "  " ++ show fxr ++ " | " ++ show fyl ++ " " ++ show fyr+      return (y, ayl \\ ayr)+    Nothing -> empty++pEqWith2 :: (Expr -> (Expr, [Attribute])) -> (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])+pEqWith2 f g x = do+  m <- satisfyWith Just+  pLog $ "pEqWith2: " ++ show x ++ " | " ++ show m+  case getEq m of+    Just y -> do+      let (fx,_)   = f (leftHandSide x)+          (gx,_)   = g (rightHandSide x)+          (fy,aly) = f (leftHandSide y)+          (gy,ary) = g (rightHandSide y)+      guard (fx == fy && gx == gy)+      pLog $ "pEqWith2 success: " ++ show fx ++ " " ++ show fy ++ " | " ++ show gx ++ " " ++ show gy+      return (y, aly \\ ary)+    Nothing -> empty++{-|+Compares the left arguments of two subsequent equations++A = 7+B = 7+C = 7++In this case B should be a simplification of A and C a simplification of B.+-}+pEqWithL :: (Expr -> (Expr, [Attribute])) -> Expr -> SEParser (Expr, [Attribute])+pEqWithL f x = do+  m <- satisfyWith Just+  pLog $ "pEqWithL: " ++ show x ++ " | " ++ show m+  case getEq m of+    Just y -> do+      let (fx,ax)   = f x+          (fyl,ayl) = f (leftHandSide y)+          (fyr,_) = f (rightHandSide y)+      -- We require two things for x to match y.l:+      -- 1. The end result must be equal+      -- 2. There should be at least some common steps (ensures that two formulas don't match if they do not use the same magic variable)+      guard (fx == fyl && fyl == fyr && (hasCommonality ax ayl || null ayl)) -- ? ax +++      pLog $ "pEqWith success: " ++ show fx ++ "  " ++ show fyl ++ " " ++ show fyr+      return (leftHandSide y, ax \\ ayl)+    Nothing -> empty++-- | Two expressions might simplify to the same expression, but their paths there are different.+--+-- This function will check that there was at least one common step in simplification.+hasCommonality :: [Attribute] -> [Attribute] -> Bool+hasCommonality xs ys =+  let xs' = map nfa xs+      ys' = map nfa ys+  in any (`elem` xs') ys'++  where+    nfa (ARule i a b) = ARule i (N.map nfComAssoc a) (nfComAssoc b)+    nfa r = r
+ src/Task/MakingASquare.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.MakingASquare (makingASquare) where++import Control.Monad.State+import Control.Applicative+import Data.Maybe+import Data.Semigroup+import Domain.Math.Expr+import Recognize.Data.Math+import Ideas.Common.Id+import Recognize.Data.Approach (Approach (Algebraic,Arithmetic))+import Recognize.Data.Attribute+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.MathStoryProblem+import Recognize.Data.StringLexer+import Recognize.Data.StringLexerOptions+import Recognize.Parsing.Derived+import Recognize.Parsing.Interpretation+import Recognize.Parsing.Parse+import Recognize.Data.Step+import Util.Expr+import Recognize.Recognizer+import Bayes.Evidence+import Task.Network.MakingASquare++makingASquare :: MathStoryProblem+makingASquare = mathStoryProblem+   { problemId   = newId "makingasquare"+   , analyzers   = [(newId "01", ana)]+   , inputFile   = Just "input/makingasquare.csv"+   , networkFile = Just "networks/MakingASquare.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { lexer      = stringLexer stringLexerOptions {replaceXByMultiplication = True}+      , recognizer = defaultRecognizer pDiagnosis . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False . myassess+      }+   myassess d =+      mconcat (map assessStep (steps d)) <>+      ans1Strat .== (if (any (`elem` (map getId $ steps d)) (map newId ["area triangle","side small square","area small square"])) then "Algebraic1" else "Algebraic2")+++assessStep :: Step -> Evidence+assessStep s+   | getId s == newId "area triangle" =+        ans1Strat1Step1 .== Just stepCorrect+   | getId s == newId "side small square" =+        ans1Strat1Step2 .== Just stepCorrect+   | getId s == newId "area small square" =+        ans1Strat1Step3 .== Just stepCorrect+   | getId s == newId "area big square Sum"+             , isJust (getExpr . fst . getValue $ s)+             , evalState (isSubExprOf defaultModulo (fromJust . getExpr . fst . getValue $ s) ((Var "b" - Var "a") ** Nat 2)) (mempty,mempty) =+        ans1Strat1Step4 .== Just stepCorrect <> ans1 .== stepCorrect -- getExpr+   | getId s == newId "area big square Sum", Normalized `elem` (snd . getValue $ s) =+        ans1Strat1Step6 .== Just stepCorrect <> ans1 .== stepCorrect+   | getId s == newId "area big square Sum" =+        ans1Strat1Step5 .== Just stepCorrect <> ans1 .== stepCorrect+   | getId s == newId "hypotenuse" =+        ans1Strat2Step1 .== Just stepCorrect+   | getId s == newId "area big square Expr", Normalized `elem` (snd . getValue $ s) =+        ans1Strat2Step3 .== Just stepCorrect <> ans1 .== stepCorrect+   | getId s == newId "area big square Expr" =+        ans1Strat2Step2 .== Just stepCorrect <> ans1 .== stepCorrect+   | otherwise =+        mempty+ where+   stepCorrect = not (hasMistakes s)++areaTriangle :: Interpretation+areaTriangle = pure ((Var "a" * Var "b") / 2, [])++areaTriangle' :: Interpretation+areaTriangle' = areaTriangle+            <|> pure (Var "a" * Var "b", [Other "M1: triangle misconception"])++sideSmallSquare :: Interpretation+sideSmallSquare = pure (Var "b" - Var "a", [])+              <|> pure (Var "a" - Var "b", [InvalidCommutativity minusSymbol])++areaSmallSquare :: Interpretation+areaSmallSquare = squared sideSmallSquare+              <|> interpret (Var "a" * Var "b") <! CommonMistake++areaBigSquare :: Interpretation+areaBigSquare = [ (4*t+a, ts ++ as)+                | (t,ts) <- areaTriangle'+                , (a,as) <- areaSmallSquare]+            <|> interpret (Var "b") >*< interpret (Var "b") >-< interpret 4 >*< areaTriangle' <! Misconception Rectangle Rectangle++hypotenuse :: Bool -> Interpretation+hypotenuse recognizeForgottenRoot = case recognizeForgottenRoot of+   True -> hyp <|> interpret (Var "a" ** 2 + Var "b" ** 2) <! ForgetSym rootSymbol+   False -> hyp++   where+   hyp = interpret (sqrt (Var "a" ** 2 + Var "b" ** 2))+         <|> interpret (Var "a" + Var "b") <! Other "M2: hypotenuse misconception"+++areaBigSquareA :: Interpretation+areaBigSquareA = squared hyp+             <|> hyp >>*<< hyp -- explicitly included because hypothesis is actually not a multivariatepolynomial (according to our spec; that does not allow division by multivariate polynomials) (because it is a root)+             <|> hyp >+< hyp <! OperatorMixedUp plusSymbol timesSymbol++   where+   hyp = hypotenuse False++--These steps have to be parsed so that the hyp step cannot be detected twice. First see if both have been completed: if not, see+--if one of them has been completed.+pAlgebraic :: InterpretationParser (Approach,[Step])+pAlgebraic = fmap ((,) Algebraic) $+   do {x <- hyp True;  y <- bigsq; _ <- many' skip; return [x,y]} |>+   do {y <- bigsq;     _ <- many' skip; return [y]} |>+   do {x <- hyp False; _ <- many' skip; return [x]}+   --+   where+     hyp recognizeForgottenRoot = pSomewhere (pNamedStep (newId "hypotenuse") (interpret $ wildcard "hyp") (hypotenuse recognizeForgottenRoot))+     bigsq = pSomewhere (pNamedStep (newId "area big square Expr") (interpret $ wildcard "A") areaBigSquareA)++pArithmetic :: InterpretationParser (Approach,[Step])+pArithmetic = (,) Arithmetic <$> pAnyOf+  [ pNamedStep (newId "area triangle") (interpret $ wildcard "at") areaTriangle+  , pNamedStep (newId "side small square") (interpret $ wildcard "sss") sideSmallSquare+  , pNamedStep (newId "area small square") (interpret $ wildcard "ass") areaSmallSquare+  , pNamedStep (newId "area big square Sum") (interpret $ wildcard "A") areaBigSquare+  ]++pDiagnosis :: InterpretationParser Diagnosis+pDiagnosis = addWildcardConstraint "at" isDefinition+          >> addWildcardConstraint "ass" isDefinition+          >> addWildcardConstraint "sss" isDefinition+          >> addWildcardConstraint "hyp" isDefinition+          >> (pAlgebraic <|> pArithmetic)+          >>= \(c,stps) -> return (newDiagnosis c stps)
+ src/Task/Matryoshka/Assess.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Assessment for matryoshka exercise.+-- For the algebraic strategy we generate labels that can be easily matched to evidence+-- For the numerical strategies we simplify look for certain computations+--+-----------------------------------------------------------------------------++module Task.Matryoshka.Assess where++import Data.Monoid+import Domain.Math.Expr+import Ideas.Utils.Uniplate+import Recognize.Data.Approach+import Bayes.Evidence+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.Diagnosis as S+import Recognize.Data.Step+import Recognize.Model.Assess+import Recognize.Model.Connectives+import Recognize.Model.Constraint+import Recognize.Model.EvidenceBuilder+import Recognize.Expr.Normalform+import Recognize.Expr.Symbols+import Task.Network.Matryoshka+import Bayes.Network++assess' :: Diagnosis -> Evidence+assess' sd =+    stringNode (apprtostring appr) ans1Strat <> --check which approach has been used+    answerCorrect 5 attrs ans1 <> --check if the answer is indeed 5+    generateEvidence buildStepsEvidence appr attrs+    where attrs = map (snd . getValue) $ steps sd+          appr  = approach sd+          apprtostring Algebraic = Just "Algebraic"+          apprtostring Numerical = Just "Numerical1"+          apprtostring (Other "Numerical2") = Just "Numerical2"+          apprtostring _         = Nothing+++buildStepsEvidence :: Approach -> EvBuilder ()+buildStepsEvidence Algebraic  = stepsAGBuilder+buildStepsEvidence Numerical = stepsN1Builder+buildStepsEvidence (Other "Numerical2") = stepsN2Builder+buildStepsEvidence _ = return ()++stepsAGBuilder :: EvBuilder ()+stepsAGBuilder = do+  -- Check for the formula+  giveNodeAndCollect ans1Strat1Step2 (withoutFailure $ exists1 (Label "Def"))++  -- Check if one or more numbers != 6 have been tried:+  let ev3_0 = withoutFailure $ exists [Label "F", LabelE "N" (approx 0 0)]+  let ev3_1 = withoutFailure $ exists [Label "F", LabelE "N" (approx 0 1)]+  let ev3_2 = withoutFailure $ exists [Label "F", LabelE "N" (approx 0 2)]+  let ev3_3 = withoutFailure $ exists [Label "F", LabelE "N" (approx 0 3)]+  let ev3_4 = withoutFailure $ exists [Label "F", LabelE "N" (approx 0 4)]++  giveNodeAndCollectAllKnown ans1Strat1Step3 [ev3_0, ev3_1, ev3_2, ev3_3, ev3_4]++  -- Check if 6 has been tried:+  giveNodeAndCollect ans1Strat1Step4 $ withoutFailure $ exists [Label "F", LabelE "N" (approx 0 5)]++  var5_a <- newVar "var5a"+  let ev5_a = exists1 (LabelE "L" var5_a)+  var5_b <- newVar "var5b"+  let ev5_b = exists1 (FinalAnswer var5_b)++  -- Only if we were able to find evidence for both LabelE and FinalAnswer+  -- and both expressions their normalforms are equal+  giveNodeAndCollectAll ans1Strat1Step5 [ev5_a, ev5_b, normalform var5_a <~> normalform var5_b]++isStepN1 :: Constraint EvBuilder [Attribute]+isStepN1 = exists1 (Label "N1")++stepsN1Builder :: EvBuilder ()+--Check for the Numerical1 strategy+stepsN1Builder = do+  n1_1 <- newVar "N1_1"+  stepBuilder ans1Strat2Step1 n1_1 (32 * 0.75) isStepN1++  n1_2 <- newVar "N1_2"+  stepBuilder ans1Strat2Step2 n1_2 (n1_1 * 0.75) isStepN1++  n1_3 <- newVar "N1_3"+  stepBuilder ans1Strat2Step3 n1_3 (n1_2 * 0.75) isStepN1++  n1_4 <- newVar "N1_4"+  stepBuilder ans1Strat2Step4 n1_4 (n1_3 * 0.75) isStepN1++  n1_5 <- newVar "N1_5"+  stepBuilder ans1Strat2Step5 n1_5 (n1_4 * 0.75) isStepN1++  giveNodeAndCollect ans1Strat2Step6 (exists1 (FinalAnswer 5))++isStepN2a :: Constraint EvBuilder [Attribute]+isStepN2a = exists1 (Label "N2a")++isStepN2b :: Constraint EvBuilder [Attribute]+isStepN2b = exists1 (Label "N2b")++stepsN2Builder :: EvBuilder ()+stepsN2Builder = do+  n2_1 <- newVar "N2_1a"+  stepBuilder ans1Strat3Step1 n2_1 8 isStepN2a++  n2_2 <- newVar "N2_2b"+  stepBuilder ans1Strat3Step2 n2_2 24 isStepN2b++  n2_3 <- newVar "N2_3a"+  stepBuilder ans1Strat3Step3 n2_3 (n2_2 * 0.25) isStepN2a++  n2_4 <- newVar "N2_4b"+  stepBuilder ans1Strat3Step4 n2_4 (n2_2 - n2_3) isStepN2b++  n2_5 <- newVar "N2_5a"+  stepBuilder ans1Strat3Step5 n2_5 (n2_4 * 0.25) isStepN2a++  n2_6 <- newVar "N2_6b"+  stepBuilder ans1Strat3Step6 n2_6 (n2_4 - n2_5) isStepN2b++  n2_7 <- newVar "N2_7a"+  stepBuilder ans1Strat3Step7 n2_7 (n2_6 * 0.25) isStepN2a++  n2_8 <- newVar "N2_8b"+  stepBuilder ans1Strat3Step8 n2_8 (n2_6 - n2_7) isStepN2b++  n2_9 <- newVar "N2_9a"+  stepBuilder ans1Strat3Step9 n2_9 (n2_8 * 0.25) isStepN2a++  n2_10 <- newVar "N2_10b"+  stepBuilder ans1Strat3Step10 n2_10 (n2_8 - n2_9) isStepN2b++  giveNodeAndCollect ans1Strat3Step11 (exists1 (FinalAnswer 5))+++stepBuilder :: Node (Maybe Bool) -> Expr -> Expr -> Constraint EvBuilder [Attribute] -> EvBuilder ()+stepBuilder n var expr c = do+  let constraint = c ==> exists1 (MatchedBy var (normalform expr))+                    ==> (failOnAnyMistake <?>> success)+  exp' <- nf <$> transformM getValueOf expr+  giveNodeAndCollectDefault n constraint var exp'
+ src/Task/Matryoshka/Recognizer.hs view
@@ -0,0 +1,276 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.Matryoshka.Recognizer (matryoshka) where++import Control.Applicative                      (many)+import Control.Arrow                            (second)+import Control.Monad                            (guard, msum, join)+import qualified Data.List                      as L+import Data.Maybe+import Recognize.Data.Approach+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.MathParserOutput+import Recognize.Data.MathParserOptions+import Recognize.Data.Diagnosis+import Recognize.Data.Math+import Recognize.Data.Step+import Recognize.Data.MathStoryProblem+import Recognize.Data.StringLexer+import Recognize.Data.StringLexerOptions+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.SubExpr.SEParser+import Recognize.Recognizer+import Recognize.SubExpr.Functions hiding (isVar)+import Recognize.SubExpr.Recognizer+import Recognize.SubExpr.Symbols+import Task.Matryoshka.Assess+import Domain.Math.Data.Relation+import Domain.Math.Expr+import Ideas.Common.Id (newId)+import Ideas.Common.Rewriting (getFunction, function)+import Ideas.Utils.Uniplate (transform, para)+import Task.Network.Matryoshka+import Bayes.Evidence ( evidenceOfAbsence )++matryoshka :: MathStoryProblem+matryoshka = mathStoryProblem+   { problemId     = newId "matryoshka"+   , processInputs = id+   , analyzers     = [(newId "02", ana)]+   , inputFile     = Just "input/matryoshka.csv"+   , networkFile   = Just "networks/Matryoshka.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { lexer      = stringLexer stringLexerOptions { variableWhitelist = ["cm"] }+      , parser     = mathParser mathParserOptions {multByConcatenation = False} . stringLexerOutput+      , recognizer = myrecognize+      , collector  = evidenceOfAbsence ans1 False . assess'+      }++   myrecognize mpo =+      let mpo2 = changeInequalities $ mathParserOutput $ fixPercentages $ removeUnit mpo+      in seRecognizer pDiagnosis mpo2++-- Somewhat of a hack, since the lexer/parser should correctly handle whitelisting of variables+-- Should be fixed once pilots are finished+removeUnit :: MathParserOutput -> MathParserOutput+removeUnit (MathParserOutput mpo che) = MathParserOutput (map math mpo) che+  where+    math (M t eth) = M t $ fmap (transform expr) eth+    expr e = case e of+      (a :*: Var "cm") -> a+      _ -> e++-- If a student at least once writes a*b% and we beyond that encounter more+-- cases of '*b', but this time without the percentage symbol then this it is extremely likely+-- for it to be forgotten. Therefore we will add this ourselves now.+fixPercentages :: MathParserOutput -> MathParserOutput+fixPercentages (MathParserOutput mpo che) = MathParserOutput (modMaths (findPercentage mpo) mpo) che+  where+    findPercentage [] = Nothing+    findPercentage (m:ms) = msum [findPercentage' m, findPercentage ms]+    findPercentage' (M _ eth) = join $ either (const Nothing) Just $ fmap (para (\e' rs ->+      let mb = case e' of+                (_ :*: b :/: 100) -> Just b+                _ -> Nothing+      in msum (mb : rs))) eth+    modMaths mp = map (modMath mp)+    modMath mp (M t eth) = M t $ fmap (modExpr mp) eth+    modExpr Nothing e = e+    modExpr mp@(Just p) e+      | hasExpr 100 e = e+      | otherwise = case (e, getFunction e) of+          (a :*: b,_)+            | b == p || a == p -> a :*: b :/: 100+            | otherwise -> modExpr mp a :*: modExpr mp b+          (_,Just (s,xs)) -> function s (map (modExpr mp) xs)+          _ -> e++pDiagnosis :: SEParser Diagnosis+pDiagnosis = do+  (appr, st) <- mostCommonStrategy <$> pSteps+  let sd = newDiagnosis appr st+      -- exprs = rights (map (getResult . getMath) st)+      -- exprAsString = concatMap show exprs+  return sd++-- In case of the Numerical approach, filter steps of Numerical1 or Numerical2 strategy depending on+-- which has more steps+mostCommonStrategy :: (Approach, [Step]) -> (Approach, [Step])+mostCommonStrategy (Numerical, xs)+  | length n2Steps `div` 2 >= length n1Steps = (Other "Numerical2", xs L.\\ n1Steps)+  | otherwise = (Numerical, xs L.\\ n2Steps)+  where+    hasN2 x = any (\y -> Label "N2a" == y || Label "N2b" == y) $ snd $ getValue x+    hasN1 x = elem (Label "N1") $ snd $ getValue x+    n2Steps = filter hasN2 xs+    n1Steps = filter hasN1 xs+mostCommonStrategy s = s++-- | See if we can predetermine which approach was taken+stratHeur :: SEParser (Maybe Approach)+stratHeur =+  withInput $ \xs -> do+    let es = mapMaybe getExpr xs+        hasDef = isFunctionCall+        hasPower x = case getFunction x of+          Nothing -> False+          Just (s,ys) -> isPowerSymbol s || any hasPower ys+    if any (\x -> hasDef x || hasPower x) es+      then Just Algebraic+      else if all (\e -> any (isSubExprOf e) es) [32,24,18]+        then Just Numerical+        else Nothing++pSteps :: SEParser (Approach, [Step])+pSteps = do+  mapp <- stratHeur+  -- If we know the strategy then call the corresponding strategy parser+  -- otherwise try both+  (ap,st,sk) <- case mapp of+    Just Algebraic -> (\(st,sk) -> (Algebraic,st,sk)) <$> pStepsAlgebraic []+    Just Numerical -> (\(_,st,sk) -> (Numerical,st,sk)) <$> pStepsArith [] 32+    Nothing -> choice'+                [ do+                  (_,st,sk) <- pStepsArith [] 32+                  guard (length st >= 1) --  Must have done at least one step+                  return (Numerical,st,sk)+                , do+                  (st,sk) <- pStepsAlgebraic []+                  guard (length st >= 1)+                  return (Algebraic,st,sk)+                , return (NoApproach,[],[])+                ]+  -- Attempt to parse the final answer separately+  fa_st <- pFinalAnswer sk+  let ss = st ++ maybeToList fa_st+  guard (length ss >= 1)+  return (ap,ss)++pStepsAlgebraic :: [Math] -> SEParser ([Step],[Math])+pStepsAlgebraic _ = (\(_, x, y) -> (x, y)) <$> pRepeat (pFormula |> pFormulaLin)++-- | Formula definition: h(x) = 32*0.75^x+pFormula :: SEParser (Expr, [Step])+pFormula = do+  pLog "pFormula"+  meq <- option (satisfyEq isVar isNat)+  let (n,at) = case meq of+        Nothing -> (newMagicNat,Nothing)+        Just (_ :==: y) -> (y, Just $ LabelE "D" y)+  (e,ss) <- pMatchSubSteps (stratBNatStep n)+  let ss' = maybe ss (`addAttributeToFront` ss) at+  return (e,ss')+  where+    stratBNatStep e = lt "n" e $ \n ->+      lbl "F" (32 * (+      (0.75 ** stop (lblE "N" (n-1) (n-1) <?> lblE "N" n n))+      <!> (0.75 * stop (lblE "N" (n-1) (n-1) <?> lblE "N" n n))+      ))++-- | Filled in formula: 32*0.75^5+pFormulaLin :: SEParser (Expr, [Step])+pFormulaLin = do+  pLog "pFormulaLin"+  e <- peek >>= getExpr+  _ <- maybeToParse $ getVarS e+  _ <- few skip+  (e',ss) <- pMatchSubSteps stratBVarStep+  (_,ss',_) <- pInOrder+    [ \_ -> do+      -- x = 3 32*0.75^x+      (_ :==: y) <- satisfyEq isVar (\ex -> isNat ex || isNumber ex)+      let ss' = addAttributeToFront (LabelE "L" y) ss+      pLog ("pFormulaLIn: " ++ show ss')+      return (y, ss')+    ]+  return (e', ss')+  where+    stratBVarStep = lt "v" newMagicVar $ \v ->+      lbl "Def" (32 * (+      (0.75 ** stop ((v-1) <!> v))+      <!> (0.75 * stop ((v-1) <!> v))+      )) <&> newMagicNat++-- | Numerical strategy+--+-- Starts with 32 and either continues to apply *0.75 (A steps)+--+-- or *.25 followed by a subtraction (S steps)+pStepsArith :: [Math] -> Expr -> SEParser (Expr, [Step],[Math])+pStepsArith xs e = do+  mb <- option (pStratS e |> pStratA stratAStep e)+  me <- safePeek+  pLog ("pStepsArith: " ++ show mb ++ " | " ++ show me)+  case mb of+    Just (es, sts) -> (\(a,b,c) -> (a,sts++b,c)) <$> pStepsArith xs es+    Nothing -> choice'+        [ do+          s <- skip+          pStepsArith (s:xs) e+        , return (e,[],xs)+        ]+  where+    stratAStep ex = lbl "N1" $ ex * (0.75 <!> 0.25)++pStratA :: (Expr -> Expr) -> Expr -> SEParser (Expr, [Step])+pStratA strat e = do+  modify $ \st -> st { optGrow = True, growF = strat }+  modify $ \st -> st { chainedEquations = True }+  resetAfter $ pMatchSubSteps (strat e)+++pStratS :: Expr -> SEParser (Expr, [Step])+pStratS e =+  choice+    [ do+      (e', ss) <- pMatchSubSteps (stratSStep_f_a e)+      _ <- few skip+      second (ss++) <$> pMatchSubSteps (stratSStep_f_b e e')+    , pMatchSubSteps (stratSStep_f_s e)+    , pMatchSubSteps (stratSStep_f_c e)+    ]+  where+    stratSStep_f_s ex = lbl "N2b" $ sub (ex - nf (ex * 0.25)) <!> sub (ex - nf (ex * 0.75)) <!> sub (ex - 8)+    stratSStep_f_a ex = lbl "N2a" (ex * (0.25 <!> 0.75))+    stratSStep_f_b ex d = lbl "N2b" $ sub (ex - d)+    stratSStep_f_c ex = lbl "N2b" $ sub (ex - 8)++++pFinalAnswer :: [Math] -> SEParser (Maybe Step)+pFinalAnswer skipped = do+  pLog "pFinalAnswer"+  rest <- many skip+  let me = closestInList (filter (\n -> isNat n && n >= 2 && n <= 10) $ mapMaybe getExpr (skipped ++ rest)) 6+  case me of+    Nothing -> pLog "empty" >> return Nothing+    Just fe -> return $ Just $ makeFAStep fe+++addAttributeToFront :: Attribute -> [Step] -> [Step]+addAttributeToFront at ss = reverse $+  case reverse ss of+    [] -> []+    (x:xs) -> addAttribute at x : xs++changeInequalities :: [Math] -> [Math]+changeInequalities = map $ \m -> fromMaybe m $ do+   r <- getRelation m+   guard $ relationType r `notElem` [EqualTo, NotEqualTo]+   return $ M (getString m) (Right $ leftHandSide r)
+ src/Task/Network/AreaAndExpression.hs view
@@ -0,0 +1,27 @@+-- generated code: do not change
+module Task.Network.AreaAndExpression where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "AreaAndExpression" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step11,node_ ans1Strat1Step12,node_ r1212_T09]
+
+layout :: Layout
+layout = [("Ans1",pt 247.0 275.0),("R1212_T09",pt 249.0 161.0),("Ans1Strat1Step11",pt 102.0 125.0),("Ans1Strat1Step12",pt 449.0 131.0),("Ans1Strat",pt 263.0 44.0)]
+
+ans1 :: Node Bool
+ans1 = Node "AreaAndExpression_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["AreaAndExpression_Ans1Strat1Step11","AreaAndExpression_Ans1Strat1Step12"] (NoisyMax [0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans1Strat :: Node String
+ans1Strat = Node "AreaAndExpression_Ans1Strat" "Solution Strategy" [("L_shape", "L_shape"),("T_shape", "T_shape")] [] (CPT [0.5,0.5])
+
+ans1Strat1Step11 :: Node (Maybe Bool)
+ans1Strat1Step11 = Node "AreaAndExpression_Ans1Strat1Step11" "Answer (0,1,0; 0,1,1; 0,1,0)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaAndExpression_Ans1Strat"] (CPT [0.245,0.745,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step12 :: Node (Maybe Bool)
+ans1Strat1Step12 = Node "AreaAndExpression_Ans1Strat1Step12" "Answer: (0,0,0; 1,1,1; 0,1,0)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaAndExpression_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.245,0.745,1.0e-2])
+
+r1212_T09 :: Node Bool
+r1212_T09 = Node "R1212_T09" "Set up geometric model" [("Yes", True),("No", False)] ["AreaAndExpression_Ans1Strat1Step11","AreaAndExpression_Ans1Strat1Step12"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/AreaOfATriangle.hs view
@@ -0,0 +1,78 @@+-- generated code: do not change
+module Task.Network.AreaOfATriangle where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "AreaOfATriangle" [node_ ans1,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans2,node_ ans2Strat1Step1,node_ ans2Strat1Step2,node_ ans3,node_ ans3Strat,node_ ans3Strat1Step1,node_ ans3Strat1Step2,node_ ans3Strat1Step3,node_ ans3Strat2Step1,node_ ans3Strat2Step2,node_ ans3Strat2Step3,node_ r1212_T08,node_ r1213_T08,node_ r12_T08,node_ r321_T08,node_ r3221_T08,node_ r3222_T08,node_ r323_T08,node_ r324_T08]
+
+layout :: Layout
+layout = [("Ans1",pt 118.0 279.0),("Ans1Strat1Step1",pt 205.0 98.0),("Ans2Strat1Step1",pt 473.0 92.0),("Ans3Strat2Step1",pt 476.0 377.0),("Ans2Strat1Step2",pt 473.0 207.0),("Ans3Strat1Step1",pt 207.0 384.0),("Ans3Strat",pt 323.0 445.0),("Ans1Strat1Step2",pt 208.0 206.0),("Ans3Strat2Step2",pt 475.0 492.0),("Ans3Strat2Step3",pt 483.0 599.0),("Ans3Strat1Step2",pt 205.0 497.0),("R323_T08",pt 49.0 546.0),("R324_T08",pt 54.0 653.0),("Ans2",pt 572.0 287.0),("Ans3",pt 336.0 689.0),("R3221_T08",pt 564.0 144.0),("Ans3Strat1Step3",pt 209.0 599.0),("R3222_T08",pt 54.0 134.0),("R1212_T08",pt 325.0 20.0),("R1213_T08",pt 329.0 159.0),("R12_T08",pt 58.0 401.0),("R321_T08",pt 592.0 425.0)]
+
+ans1 :: Node Bool
+ans1 = Node "AreaOfATriangle_Ans1" "Q1 Answer" [("Correct", True),("Incorrect", False)] ["AreaOfATriangle_Ans1Strat1Step2"] (CPT [0.95,5.0e-2,5.0e-2,0.95,0.5,0.5])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "AreaOfATriangle_Ans1Strat1Step1" "10x/2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] [] (CPT [0.5,0.5,0.0])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "AreaOfATriangle_Ans1Strat1Step2" "Answer: \"5x\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans1Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2 :: Node Bool
+ans2 = Node "AreaOfATriangle_Ans2" "Q2 Answer" [("Correct", True),("Incorrect", False)] ["AreaOfATriangle_Ans2Strat1Step2"] (CPT [0.95,5.0e-2,5.0e-2,0.95,0.5,0.5])
+
+ans2Strat1Step1 :: Node (Maybe Bool)
+ans2Strat1Step1 = Node "AreaOfATriangle_Ans2Strat1Step1" "2(x+3)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] [] (CPT [0.4,0.6,0.0])
+
+ans2Strat1Step2 :: Node (Maybe Bool)
+ans2Strat1Step2 = Node "AreaOfATriangle_Ans2Strat1Step2" "Answer: \"2x+6\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans2Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans3 :: Node Bool
+ans3 = Node "AreaOfATriangle_Ans3" "Q3 Answer" [("Correct", True),("Incorrect", False)] ["AreaOfATriangle_Ans3Strat1Step3","AreaOfATriangle_Ans3Strat2Step3"] (NoisyMax [0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans3Strat :: Node String
+ans3Strat = Node "AreaOfATriangle_Ans3Strat" "Q3 Solution Strategy" [("Algebraic", "Algebraic"),("Numeric", "Numeric")] [] (CPT [0.72,0.28])
+
+ans3Strat1Step1 :: Node (Maybe Bool)
+ans3Strat1Step1 = Node "AreaOfATriangle_Ans3Strat1Step1" "5x=2x+6" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat","AreaOfATriangle_Ans1Strat1Step2","AreaOfATriangle_Ans2Strat1Step2"] (CPT [0.695,0.295,1.0e-2,0.395,0.595,1.0e-2,0.5,0.4,0.1,0.395,0.595,1.0e-2,0.295,0.695,1.0e-2,0.4,0.5,0.1,0.5,0.4,0.1,0.4,0.5,0.1,0.4,0.4,0.2,9.0e-3,1.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,1.0e-3,9.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans3Strat1Step2 :: Node (Maybe Bool)
+ans3Strat1Step2 = Node "AreaOfATriangle_Ans3Strat1Step2" "3x=6" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat1Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans3Strat1Step3 :: Node (Maybe Bool)
+ans3Strat1Step3 = Node "AreaOfATriangle_Ans3Strat1Step3" "Answer: \"2\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat1Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans3Strat2Step1 :: Node (Maybe Bool)
+ans3Strat2Step1 = Node "AreaOfATriangle_Ans3Strat2Step1" "Try <n> != 2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat","AreaOfATriangle_Ans1Strat1Step2","AreaOfATriangle_Ans2Strat1Step2"] (CPT [9.0e-3,1.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,1.0e-3,9.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.695,0.295,1.0e-2,0.395,0.595,1.0e-2,0.5,0.4,0.1,0.395,0.595,1.0e-2,0.295,0.695,1.0e-2,0.4,0.5,0.1,0.5,0.4,0.1,0.4,0.5,0.1,0.4,0.4,0.2])
+
+ans3Strat2Step2 :: Node (Maybe Bool)
+ans3Strat2Step2 = Node "AreaOfATriangle_Ans3Strat2Step2" "Try <n> == 2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat2Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans3Strat2Step3 :: Node (Maybe Bool)
+ans3Strat2Step3 = Node "AreaOfATriangle_Ans3Strat2Step3" "Answer: \"2\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["AreaOfATriangle_Ans3Strat2Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r1212_T08 :: Node Bool
+r1212_T08 = Node "R1212_T08" "Set up geometric model" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans1Strat1Step1","AreaOfATriangle_Ans2Strat1Step1"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r1213_T08 :: Node Bool
+r1213_T08 = Node "R1213_T08" "Set up linear model" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans1Strat1Step1","AreaOfATriangle_Ans2Strat1Step1"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r12_T08 :: Node Bool
+r12_T08 = Node "R12_T08" "Set up algebraic equations" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans3Strat1Step1"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r321_T08 :: Node Bool
+r321_T08 = Node "R321_T08" "Substitute" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans3Strat2Step1","AreaOfATriangle_Ans3Strat2Step2"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r3221_T08 :: Node Bool
+r3221_T08 = Node "R3221_T08" "Expand expressions" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans2Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r3222_T08 :: Node String
+r3222_T08 = Node "R3222_T08" "Divide out common factors" [("Correctr", "Correctr"),("Incorrect", "Incorrect")] ["AreaOfATriangle_Ans1Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r323_T08 :: Node Bool
+r323_T08 = Node "R323_T08" "Simplify by addition and subtraction" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans3Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r324_T08 :: Node Bool
+r324_T08 = Node "R324_T08" "Simplify by multiplication and division" [("Yes", True),("No", False)] ["AreaOfATriangle_Ans3Strat1Step3"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/CarRental.hs view
@@ -0,0 +1,81 @@+-- generated code: do not change
+module Task.Network.CarRental where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "CarRental" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans1Strat1Step31,node_ ans1Strat1Step32,node_ ans1Strat1Step3Path,node_ ans1Strat1Step41,node_ ans1Strat1Step42,node_ ans1Strat1Step51,node_ ans1Strat1Step52,node_ ans1Strat1Step6,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat2Step3,node_ r11_T02,node_ r1211_T02,node_ r1213_T02,node_ r12_T02,node_ r13_T02,node_ r31_T02,node_ r323_T02,node_ r324_T02]
+
+layout :: Layout
+layout = [("Ans1",pt 509.0 760.0),("Ans1Strat1Step2",pt 245.0 207.0),("Ans1Strat1Step31",pt 67.0 331.0),("Ans1Strat1Step41",pt 66.0 444.0),("Ans1Strat1Step51",pt 67.0 557.0),("Ans1Strat",pt 439.0 39.0),("Ans1Strat2Step1",pt 800.0 163.0),("Ans1Strat2Step2",pt 803.0 310.0),("Ans1Strat1Step32",pt 433.0 333.0),("Ans1Strat1Step42",pt 436.0 430.0),("Ans1Strat1Step52",pt 436.0 531.0),("Ans1Strat1Step1",pt 247.0 105.0),("Ans1Strat1Step6",pt 243.0 694.0),("R1211_T02",pt 413.0 153.0),("R12_T02",pt 53.0 189.0),("R13_T02",pt 586.0 414.0),("R11_T02",pt 586.0 214.0),("R31_T02",pt 952.0 229.0),("R323_T02",pt 212.0 472.0),("R324_T02",pt 219.0 574.0),("R1213_T02",pt 60.0 101.0),("Ans1Strat2Step3",pt 804.0 423.0),("Ans1Strat1Step3Path",pt 245.0 292.0)]
+
+ans1 :: Node Bool
+ans1 = Node "CarRental_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["CarRental_Ans1Strat2Step3","CarRental_Ans1Strat1Step6"] (NoisyMax [0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans1Strat :: Node String
+ans1Strat = Node "CarRental_Ans1Strat" "Solution Strategy" [("Algebraic", "Algebraic"),("Numerical", "Numerical")] [] (CPT [0.79,0.21])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "CarRental_Ans1Strat1Step1" "d: distance; c: cost" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat"] (CPT [0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "CarRental_Ans1Strat1Step2" "c=20+0.25*d" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step31 :: Node (Maybe Bool)
+ans1Strat1Step31 = Node "CarRental_Ans1Strat1Step31" "20+0.25*d=43" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step2","CarRental_Ans1Strat1Step3Path"] (CPT [0.7,0.29,1.0e-2,5.0e-3,5.0e-3,0.99,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step32 :: Node (Maybe Bool)
+ans1Strat1Step32 = Node "CarRental_Ans1Strat1Step32" "20+0.25*d>43" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step2","CarRental_Ans1Strat1Step3Path"] (CPT [5.0e-3,5.0e-3,0.99,0.6,0.39,1.0e-2,5.0e-3,5.0e-3,0.99,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step3Path :: Node String
+ans1Strat1Step3Path = Node "CarRental_Ans1Strat1Step3Path" "Solution Path" [("Equation", "Equation"),("Inequality", "Inequality")] [] (CPT [0.6,0.4])
+
+ans1Strat1Step41 :: Node (Maybe Bool)
+ans1Strat1Step41 = Node "CarRental_Ans1Strat1Step41" "0.25*dt=23" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step31"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step42 :: Node (Maybe Bool)
+ans1Strat1Step42 = Node "CarRental_Ans1Strat1Step42" "0.25*d>23" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step32"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step51 :: Node (Maybe Bool)
+ans1Strat1Step51 = Node "CarRental_Ans1Strat1Step51" "d=92" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step41"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step52 :: Node (Maybe Bool)
+ans1Strat1Step52 = Node "CarRental_Ans1Strat1Step52" "d>92" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step42"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step6 :: Node (Maybe Bool)
+ans1Strat1Step6 = Node "CarRental_Ans1Strat1Step6" "Answer: \">=92\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat1Step52","CarRental_Ans1Strat1Step51"] (NoisyMax [0,1,2,0,1,2] [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,4.999999999999449e-4,4.999999999999449e-4,0.999])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "CarRental_Ans1Strat2Step1" "Try <n> != 92" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.595,0.395,1.0e-2])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "CarRental_Ans1Strat2Step2" "Try <n> == 92" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat2Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step3 :: Node (Maybe Bool)
+ans1Strat2Step3 = Node "CarRental_Ans1Strat2Step3" "Answer: \">=92\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["CarRental_Ans1Strat2Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r11_T02 :: Node Bool
+r11_T02 = Node "R11_T02" "Set up numerical expressions" [("Yes", True),("No", False)] ["CarRental_Ans1Strat2Step1","CarRental_Ans1Strat2Step2"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1211_T02 :: Node Bool
+r1211_T02 = Node "R1211_T02" "Choose variables" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step1"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1213_T02 :: Node Bool
+r1213_T02 = Node "R1213_T02" "Set up linear model" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r12_T02 :: Node Bool
+r12_T02 = Node "R12_T02" "Set up algebraic equations" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step31"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r13_T02 :: Node Bool
+r13_T02 = Node "R13_T02" "Set up algebraic inequalities" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step32"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r31_T02 :: Node Bool
+r31_T02 = Node "R31_T02" "Use numerical expressions" [("Yes", True),("No", False)] ["CarRental_Ans1Strat2Step2","CarRental_Ans1Strat2Step1"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r323_T02 :: Node Bool
+r323_T02 = Node "R323_T02" "Simplify by addition and subtraction" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step41","CarRental_Ans1Strat1Step42"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r324_T02 :: Node Bool
+r324_T02 = Node "R324_T02" "Simplify by multiplication and division" [("Yes", True),("No", False)] ["CarRental_Ans1Strat1Step51","CarRental_Ans1Strat1Step52"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/MagicTrick.hs view
@@ -0,0 +1,102 @@+-- generated code: do not change
+module Task.Network.MagicTrick where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "MagicTrick" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans1Strat1Step3,node_ ans1Strat1Step4,node_ ans1Strat1Step5,node_ ans1Strat1Step6,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat2Step3,node_ ans1Strat2Step4,node_ ans1Strat2Step5,node_ ans1Strat2Step6,node_ ans1Strat2Step7,node_ ans1Strat3Step1,node_ ans1Strat3Step2,node_ ans1Strat4Step1,node_ ans1Strat4Step2,node_ ans1Strat4Step3,node_ ans1Strat4Step4,node_ ans1Strat4Step5,node_ ans1Strat4Step6,node_ ans1Strat4Step7,node_ r11_T05,node_ r1211_T05,node_ r121_T05,node_ r31_T05,node_ r3221_T05,node_ r3223_T05]
+
+layout :: Layout
+layout = [("Ans1",pt 488.0 757.0),("Ans1Strat1Step2",pt 57.0 193.0),("Ans1Strat1Step3",pt 58.0 306.0),("Ans1Strat1Step4",pt 57.0 426.0),("Ans1Strat1Step5",pt 59.0 545.0),("Ans1Strat1Step6",pt 62.0 664.0),("Ans1Strat",pt 506.0 38.0),("Ans1Strat2Step1",pt 356.0 99.0),("Ans1Strat2Step2",pt 354.0 198.0),("Ans1Strat2Step3",pt 358.0 293.0),("Ans1Strat2Step4",pt 356.0 389.0),("Ans1Strat2Step5",pt 359.0 483.0),("Ans1Strat3Step1",pt 504.0 145.0),("Ans1Strat3Step2",pt 501.0 629.0),("Ans1Strat4Step1",pt 718.0 100.0),("Ans1Strat4Step2",pt 721.0 204.0),("Ans1Strat4Step3",pt 721.0 305.0),("Ans1Strat4Step4",pt 722.0 406.0),("Ans1Strat4Step5",pt 720.0 497.0),("Ans1Strat2Step6",pt 356.0 578.0),("Ans1Strat2Step7",pt 358.0 680.0),("Ans1Strat4Step6",pt 722.0 592.0),("Ans1Strat4Step7",pt 724.0 696.0),("R1211_T05",pt 205.0 167.0),("R11_T05",pt 559.0 277.0),("R31_T05",pt 554.0 453.0),("R3221_T05",pt 199.0 399.0),("R121_T05",pt 183.0 278.0),("R3223_T05",pt 194.0 513.0),("Ans1Strat1Step1",pt 58.0 83.0)]
+
+ans1 :: Node Bool
+ans1 = Node "MagicTrick_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["MagicTrick_Ans1Strat1Step6","MagicTrick_Ans1Strat2Step7","MagicTrick_Ans1Strat3Step2","MagicTrick_Ans1Strat4Step7"] (NoisyMax [0,1,2,0,1,2,0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,6.999999999999995e-2,0.93])
+
+ans1Strat :: Node String
+ans1Strat = Node "MagicTrick_Ans1Strat" "Solution Strategy" [("Algebraic1", "Algebraic1"),("Algebraic2", "Algebraic2"),("Numeric1", "Numeric1"),("Numeric2", "Numeric2")] [] (CPT [0.28,0.27,0.15,0.3])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "MagicTrick_Ans1Strat1Step1" "x - variable" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat"] (CPT [0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "MagicTrick_Ans1Strat1Step2" "((x+8)*3-4+x)/4+2-x" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat1Step1"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step3 :: Node (Maybe Bool)
+ans1Strat1Step3 = Node "MagicTrick_Ans1Strat1Step3" "(3x+24-4+x)/4+2-x" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat1Step2"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step4 :: Node (Maybe Bool)
+ans1Strat1Step4 = Node "MagicTrick_Ans1Strat1Step4" "(4x+20)/4+2-x" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat1Step3"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step5 :: Node (Maybe Bool)
+ans1Strat1Step5 = Node "MagicTrick_Ans1Strat1Step5" "x+5+2-x" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat1Step4"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step6 :: Node (Maybe Bool)
+ans1Strat1Step6 = Node "MagicTrick_Ans1Strat1Step6" "Answer: \"7\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat1Step5"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "MagicTrick_Ans1Strat2Step1" "x+8" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "MagicTrick_Ans1Strat2Step2" "(x+8)*3=3x+24" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step3 :: Node (Maybe Bool)
+ans1Strat2Step3 = Node "MagicTrick_Ans1Strat2Step3" "3x+24-4=3x+20" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step4 :: Node (Maybe Bool)
+ans1Strat2Step4 = Node "MagicTrick_Ans1Strat2Step4" "3x+20+x=4x+20" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step3"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step5 :: Node (Maybe Bool)
+ans1Strat2Step5 = Node "MagicTrick_Ans1Strat2Step5" "(4x+20)/4=x+5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step4"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step6 :: Node (Maybe Bool)
+ans1Strat2Step6 = Node "MagicTrick_Ans1Strat2Step6" "x+5+2=x+7" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step5"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step7 :: Node (Maybe Bool)
+ans1Strat2Step7 = Node "MagicTrick_Ans1Strat2Step7" "Answer: \"x+7-x=7\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat2Step6"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step1 :: Node (Maybe Bool)
+ans1Strat3Step1 = Node "MagicTrick_Ans1Strat3Step1" "((<n>+8)*3-4+<n>)/4+2-<n>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step2 :: Node (Maybe Bool)
+ans1Strat3Step2 = Node "MagicTrick_Ans1Strat3Step2" "answer: \"7\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat3Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step1 :: Node (Maybe Bool)
+ans1Strat4Step1 = Node "MagicTrick_Ans1Strat4Step1" "<n>+8=<a1>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.595,0.395,1.0e-2])
+
+ans1Strat4Step2 :: Node (Maybe Bool)
+ans1Strat4Step2 = Node "MagicTrick_Ans1Strat4Step2" "<a1>*3=<a2>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step3 :: Node (Maybe Bool)
+ans1Strat4Step3 = Node "MagicTrick_Ans1Strat4Step3" "<a2>-4=<a3>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step4 :: Node (Maybe Bool)
+ans1Strat4Step4 = Node "MagicTrick_Ans1Strat4Step4" "<a3>+<n>=<a4>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step3"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step5 :: Node (Maybe Bool)
+ans1Strat4Step5 = Node "MagicTrick_Ans1Strat4Step5" "<a4>/4=<a5>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step4"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step6 :: Node (Maybe Bool)
+ans1Strat4Step6 = Node "MagicTrick_Ans1Strat4Step6" "<a5>+2=<a6>" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step5"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step7 :: Node (Maybe Bool)
+ans1Strat4Step7 = Node "MagicTrick_Ans1Strat4Step7" "Answer: \"<a6>-<n>=7\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MagicTrick_Ans1Strat4Step6"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r11_T05 :: Node Bool
+r11_T05 = Node "R11_T05" "Set up numerical expressions" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat3Step1","MagicTrick_Ans1Strat4Step1","MagicTrick_Ans1Strat4Step2","MagicTrick_Ans1Strat4Step3","MagicTrick_Ans1Strat4Step4","MagicTrick_Ans1Strat4Step5","MagicTrick_Ans1Strat4Step6","MagicTrick_Ans1Strat4Step7"] (NoisyAdder [1,2,2,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1211_T05 :: Node Bool
+r1211_T05 = Node "R1211_T05" "Choose variables" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat1Step1","MagicTrick_Ans1Strat2Step1"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r121_T05 :: Node Bool
+r121_T05 = Node "R121_T05" "Set up algebraic expressions" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat2Step1","MagicTrick_Ans1Strat1Step2","MagicTrick_Ans1Strat2Step2","MagicTrick_Ans1Strat2Step3","MagicTrick_Ans1Strat2Step4","MagicTrick_Ans1Strat2Step5","MagicTrick_Ans1Strat2Step6","MagicTrick_Ans1Strat2Step7"] (NoisyAdder [1,2,2,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r31_T05 :: Node Bool
+r31_T05 = Node "R31_T05" "Use numerical expressions" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat2Step3","MagicTrick_Ans1Strat2Step6","MagicTrick_Ans1Strat3Step2","MagicTrick_Ans1Strat4Step1","MagicTrick_Ans1Strat4Step2","MagicTrick_Ans1Strat4Step3","MagicTrick_Ans1Strat4Step4","MagicTrick_Ans1Strat4Step5","MagicTrick_Ans1Strat4Step6","MagicTrick_Ans1Strat4Step7"] (NoisyAdder [1,2,2,2,2,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r3221_T05 :: Node Bool
+r3221_T05 = Node "R3221_T05" "Expand expressions" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat1Step3","MagicTrick_Ans1Strat2Step2","MagicTrick_Ans1Strat2Step5","MagicTrick_Ans1Strat1Step5"] (NoisyAdder [1,2,2,2,2] [1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r3223_T05 :: Node Bool
+r3223_T05 = Node "R3223_T05" "Combine like terms" [("Yes", True),("No", False)] ["MagicTrick_Ans1Strat1Step4","MagicTrick_Ans1Strat1Step6","MagicTrick_Ans1Strat2Step4","MagicTrick_Ans1Strat2Step7"] (NoisyAdder [1,2,2,2,2] [1.0,1.0,1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/MakingASquare.hs view
@@ -0,0 +1,57 @@+-- generated code: do not change
+module Task.Network.MakingASquare where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "MakingASquare" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans1Strat1Step3,node_ ans1Strat1Step4,node_ ans1Strat1Step5,node_ ans1Strat1Step6,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat2Step3,node_ r1212_T04,node_ r1214_T04,node_ r3221_T04,node_ r3223_T04]
+
+layout :: Layout
+layout = [("Ans1",pt 357.0 622.0),("Ans1Strat1Step1",pt 136.0 83.0),("Ans1Strat1Step2",pt 132.0 178.0),("Ans1Strat",pt 329.0 19.0),("Ans1Strat2Step1",pt 503.0 172.0),("Ans1Strat2Step2",pt 500.0 321.0),("Ans1Strat1Step3",pt 134.0 273.0),("Ans1Strat1Step4",pt 138.0 368.0),("Ans1Strat1Step5",pt 141.0 457.0),("Ans1Strat1Step6",pt 139.0 549.0),("Ans1Strat2Step3",pt 505.0 447.0),("R3221_T04",pt 311.0 396.0),("R1212_T04",pt 310.0 102.0),("R1214_T04",pt 313.0 233.0),("R3223_T04",pt 309.0 515.0)]
+
+ans1 :: Node Bool
+ans1 = Node "MakingASquare_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["MakingASquare_Ans1Strat1Step6","MakingASquare_Ans1Strat2Step3"] (NoisyMax [0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans1Strat :: Node String
+ans1Strat = Node "MakingASquare_Ans1Strat" "Solution Strategy" [("Algebraic1", "Algebraic1"),("Algebraic2", "Algebraic2")] [] (CPT [0.37,0.63])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "MakingASquare_Ans1Strat1Step1" "area of a triangle: a*b/2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat"] (CPT [0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "MakingASquare_Ans1Strat1Step2" "side of a small square: b-a" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat1Step1"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step3 :: Node (Maybe Bool)
+ans1Strat1Step3 = Node "MakingASquare_Ans1Strat1Step3" "area of a small square: (b-a)^2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat1Step2"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step4 :: Node (Maybe Bool)
+ans1Strat1Step4 = Node "MakingASquare_Ans1Strat1Step4" "area of a large square: 4*a*b/2+(b-a)^2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat1Step3"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step5 :: Node (Maybe Bool)
+ans1Strat1Step5 = Node "MakingASquare_Ans1Strat1Step5" "2ab+b^2 - 2ab +a^2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat1Step4"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step6 :: Node (Maybe Bool)
+ans1Strat1Step6 = Node "MakingASquare_Ans1Strat1Step6" "Answer:\" b^2 + a^2\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat1Step5"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "MakingASquare_Ans1Strat2Step1" "hypotenuse: sqrt(a^2+b^2)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "MakingASquare_Ans1Strat2Step2" "area of a large square: hypotenuse^2" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat2Step1"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step3 :: Node (Maybe Bool)
+ans1Strat2Step3 = Node "MakingASquare_Ans1Strat2Step3" "Answer: \"b^2 + a^2\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["MakingASquare_Ans1Strat2Step2"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r1212_T04 :: Node Bool
+r1212_T04 = Node "R1212_T04" "Set up geometric model" [("Yes", True),("No", False)] ["MakingASquare_Ans1Strat2Step2","MakingASquare_Ans1Strat2Step1","MakingASquare_Ans1Strat1Step4","MakingASquare_Ans1Strat1Step3","MakingASquare_Ans1Strat1Step2","MakingASquare_Ans1Strat1Step1"] (NoisyAdder [1,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r1214_T04 :: Node Bool
+r1214_T04 = Node "R1214_T04" "Set up quadratic model" [("Yes", True),("No", False)] ["MakingASquare_Ans1Strat1Step1","MakingASquare_Ans1Strat1Step3","MakingASquare_Ans1Strat2Step2"] (NoisyAdder [1,2,2,2] [1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r3221_T04 :: Node Bool
+r3221_T04 = Node "R3221_T04" "Expand expressions" [("Yes", True),("No", False)] ["MakingASquare_Ans1Strat1Step5"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r3223_T04 :: Node Bool
+r3223_T04 = Node "R3223_T04" "Combine like terms" [("Yes", True),("No", False)] ["MakingASquare_Ans1Strat1Step6"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/Matryoshka.hs view
@@ -0,0 +1,111 @@+-- generated code: do not change
+module Task.Network.Matryoshka where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "Matryoshka" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans1Strat1Step3,node_ ans1Strat1Step4,node_ ans1Strat1Step5,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat2Step3,node_ ans1Strat2Step4,node_ ans1Strat2Step5,node_ ans1Strat2Step6,node_ ans1Strat3Step1,node_ ans1Strat3Step10,node_ ans1Strat3Step11,node_ ans1Strat3Step2,node_ ans1Strat3Step3,node_ ans1Strat3Step4,node_ ans1Strat3Step5,node_ ans1Strat3Step6,node_ ans1Strat3Step7,node_ ans1Strat3Step8,node_ ans1Strat3Step9,node_ r11_T10,node_ r11_T10_P1,node_ r11_T10_P2,node_ r1211_T10,node_ r1215_T10,node_ r31_T10,node_ r31_T10_P1,node_ r31_T10_P2,node_ r321_T10]
+
+layout :: Layout
+layout = [("Ans1",pt 388.0 895.0),("Ans1Strat1Step1",pt 290.0 148.0),("Ans1Strat1Step2",pt 288.0 316.0),("Ans1Strat1Step3",pt 288.0 483.0),("Ans1Strat1Step4",pt 289.0 658.0),("Ans1Strat",pt 510.0 60.0),("Ans1Strat2Step1",pt 476.0 195.0),("Ans1Strat2Step2",pt 473.0 292.0),("Ans1Strat2Step3",pt 476.0 400.0),("Ans1Strat2Step4",pt 478.0 509.0),("Ans1Strat2Step5",pt 479.0 624.0),("Ans1Strat3Step1",pt 667.0 116.0),("Ans1Strat3Step2",pt 821.0 154.0),("Ans1Strat3Step3",pt 962.0 202.0),("Ans1Strat3Step4",pt 1002.0 301.0),("Ans1Strat3Step5",pt 1043.0 400.0),("Ans1Strat3Step6",pt 1040.0 499.0),("Ans1Strat3Step7",pt 1020.0 607.0),("Ans1Strat1Step5",pt 292.0 757.0),("Ans1Strat2Step6",pt 479.0 734.0),("Ans1Strat3Step8",pt 976.0 705.0),("Ans1Strat3Step9",pt 896.0 802.0),("Ans1Strat3Step10",pt 712.0 875.0),("Ans1Strat3Step11",pt 555.0 923.0),("R1211_T10",pt 194.0 227.0),("R11_T10",pt 649.0 388.0),("R31_T10",pt 629.0 690.0),("R321_T10",pt 208.0 567.0),("R1215_T10",pt 187.0 384.0),("R11_T10_P1",pt 631.0 258.0),("R11_T10_P2",pt 816.0 296.0),("R31_T10_P1",pt 656.0 553.0),("R31_T10_P2",pt 822.0 558.0)]
+
+ans1 :: Node Bool
+ans1 = Node "Matryoshka_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["Matryoshka_Ans1Strat1Step5","Matryoshka_Ans1Strat2Step6","Matryoshka_Ans1Strat3Step11"] (NoisyMax [0,1,2,0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans1Strat :: Node String
+ans1Strat = Node "Matryoshka_Ans1Strat" "Solution Strategy" [("Algebraic", "Algebraic"),("Numerical1", "Numerical1"),("Numerical2", "Numerical2")] [] (CPT [0.32,0.28,0.4])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "Matryoshka_Ans1Strat1Step1" "h: height; n: number" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat"] (CPT [0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "Matryoshka_Ans1Strat1Step2" "h(n)=32*0,75^(n-1)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat1Step1"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step3 :: Node (Maybe Bool)
+ans1Strat1Step3 = Node "Matryoshka_Ans1Strat1Step3" "Try <n> != 6" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat1Step2"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step4 :: Node (Maybe Bool)
+ans1Strat1Step4 = Node "Matryoshka_Ans1Strat1Step4" "Try <n> == 6" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat1Step3"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step5 :: Node (Maybe Bool)
+ans1Strat1Step5 = Node "Matryoshka_Ans1Strat1Step5" "Answer: \"5\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat1Step4"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "Matryoshka_Ans1Strat2Step1" "2nd: 32*0.75=24" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "Matryoshka_Ans1Strat2Step2" "3d: 24*0.75=18" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat2Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step3 :: Node (Maybe Bool)
+ans1Strat2Step3 = Node "Matryoshka_Ans1Strat2Step3" "4th: 18*0.75=13.5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat2Step2"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step4 :: Node (Maybe Bool)
+ans1Strat2Step4 = Node "Matryoshka_Ans1Strat2Step4" "5th: 13.5*0.75=10.125" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat2Step3"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step5 :: Node (Maybe Bool)
+ans1Strat2Step5 = Node "Matryoshka_Ans1Strat2Step5" "6th: 10.125*0.75=7.594" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat2Step4"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step6 :: Node (Maybe Bool)
+ans1Strat2Step6 = Node "Matryoshka_Ans1Strat2Step6" "Answer: \"5\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat2Step5"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step1 :: Node (Maybe Bool)
+ans1Strat3Step1 = Node "Matryoshka_Ans1Strat3Step1" "32*25/100=8" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.595,0.395,1.0e-2])
+
+ans1Strat3Step10 :: Node (Maybe Bool)
+ans1Strat3Step10 = Node "Matryoshka_Ans1Strat3Step10" "6th: 10.125-2.531=7.594" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step9"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step11 :: Node (Maybe Bool)
+ans1Strat3Step11 = Node "Matryoshka_Ans1Strat3Step11" "Answer: \"5\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step10"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step2 :: Node (Maybe Bool)
+ans1Strat3Step2 = Node "Matryoshka_Ans1Strat3Step2" "2nd: 32-8=24" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step1"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step3 :: Node (Maybe Bool)
+ans1Strat3Step3 = Node "Matryoshka_Ans1Strat3Step3" "24*25/100=6" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step4 :: Node (Maybe Bool)
+ans1Strat3Step4 = Node "Matryoshka_Ans1Strat3Step4" "3d: 24-6=18" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step3"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step5 :: Node (Maybe Bool)
+ans1Strat3Step5 = Node "Matryoshka_Ans1Strat3Step5" "18*25/100=4.5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step4"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step6 :: Node (Maybe Bool)
+ans1Strat3Step6 = Node "Matryoshka_Ans1Strat3Step6" "4th: 18-4.5=13.5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step5"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step7 :: Node (Maybe Bool)
+ans1Strat3Step7 = Node "Matryoshka_Ans1Strat3Step7" "13.5*25/100=3.375" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step6"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step8 :: Node (Maybe Bool)
+ans1Strat3Step8 = Node "Matryoshka_Ans1Strat3Step8" "5th: 13.5-3.375=10.125" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step7"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step9 :: Node (Maybe Bool)
+ans1Strat3Step9 = Node "Matryoshka_Ans1Strat3Step9" "10.125*25/100=2.531" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Matryoshka_Ans1Strat3Step8"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r11_T10 :: Node Bool
+r11_T10 = Node "R11_T10" "Set up numerical expressions" [("Yes", True),("No", False)] ["R11_T10_P1","R11_T10_P2"] (CPT [1.0,0.0,0.5,0.5,0.5,0.5,0.0,1.0])
+
+r11_T10_P1 :: Node Bool
+r11_T10_P1 = Node "R11_T10_P1" "Set up numeric expressions (part 1)" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat2Step1","Matryoshka_Ans1Strat2Step2","Matryoshka_Ans1Strat2Step3","Matryoshka_Ans1Strat2Step4","Matryoshka_Ans1Strat2Step5"] (NoisyAdder [1,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r11_T10_P2 :: Node Bool
+r11_T10_P2 = Node "R11_T10_P2" "Set up numeric expressions (part 2)" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat3Step1","Matryoshka_Ans1Strat3Step2","Matryoshka_Ans1Strat3Step3","Matryoshka_Ans1Strat3Step4","Matryoshka_Ans1Strat3Step5","Matryoshka_Ans1Strat3Step6","Matryoshka_Ans1Strat3Step7","Matryoshka_Ans1Strat3Step8","Matryoshka_Ans1Strat3Step9","Matryoshka_Ans1Strat3Step10"] (NoisyAdder [1,2,2,2,2,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1211_T10 :: Node Bool
+r1211_T10 = Node "R1211_T10" "Choose variables" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat1Step1"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1215_T10 :: Node Bool
+r1215_T10 = Node "R1215_T10" "Set up exponential model" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r31_T10 :: Node Bool
+r31_T10 = Node "R31_T10" "Use numerical expressions" [("Yes", True),("No", False)] ["R31_T10_P1","R31_T10_P2"] (CPT [1.0,0.0,0.5,0.5,0.5,0.5,0.0,1.0])
+
+r31_T10_P1 :: Node Bool
+r31_T10_P1 = Node "R31_T10_P1" "Use numeric expressions (part 1)" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat2Step5","Matryoshka_Ans1Strat2Step4","Matryoshka_Ans1Strat2Step3","Matryoshka_Ans1Strat2Step2","Matryoshka_Ans1Strat2Step1"] (NoisyAdder [1,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r31_T10_P2 :: Node Bool
+r31_T10_P2 = Node "R31_T10_P2" "Use numeric expressions (part 2)" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat3Step10","Matryoshka_Ans1Strat3Step9","Matryoshka_Ans1Strat3Step8","Matryoshka_Ans1Strat3Step7","Matryoshka_Ans1Strat3Step6","Matryoshka_Ans1Strat3Step5","Matryoshka_Ans1Strat3Step4","Matryoshka_Ans1Strat3Step2","Matryoshka_Ans1Strat3Step1","Matryoshka_Ans1Strat3Step3"] (NoisyAdder [1,2,2,2,2,2,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r321_T10 :: Node Bool
+r321_T10 = Node "R321_T10" "Substitute" [("Yes", True),("No", False)] ["Matryoshka_Ans1Strat1Step3","Matryoshka_Ans1Strat1Step4"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/Pattern.hs view
@@ -0,0 +1,99 @@+-- generated code: do not change
+module Task.Network.Pattern where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "Pattern" [node_ ans1,node_ ans1Strat,node_ ans1Strat1Step11,node_ ans1Strat1Step12,node_ ans1Strat1Step1Path,node_ ans1Strat1Step2,node_ ans1Strat1Step31,node_ ans1Strat1Step32,node_ ans1Strat1Step3Path,node_ ans1Strat1Step41,node_ ans1Strat1Step42,node_ ans1Strat1Step51,node_ ans1Strat1Step52,node_ ans1Strat1Step6,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat2Step3,node_ ans1Strat3Step1,node_ ans1Strat3Step2,node_ ans1Strat3Step3,node_ ans1Strat3Step4,node_ ans1Strat3Step5,node_ r1211_T03,node_ r1213_T03,node_ r12_T03,node_ r13_T03,node_ r31_T03,node_ r323_T03,node_ r324_T03]
+
+layout :: Layout
+layout = [("Ans1",pt 567.0 714.0),("Ans1Strat3Step1",pt 845.0 101.0),("Ans1Strat3Step2",pt 848.0 235.0),("Ans1Strat3Step3",pt 851.0 371.0),("Ans1Strat",pt 607.0 30.0),("Ans1Strat1Step11",pt 253.0 58.0),("Ans1Strat1Step12",pt 427.0 178.0),("Ans1Strat1Step2",pt 261.0 197.0),("Ans1Strat1Step31",pt 97.0 295.0),("Ans1Strat1Step41",pt 99.0 382.0),("Ans1Strat2Step1",pt 645.0 124.0),("Ans1Strat2Step2",pt 645.0 375.0),("Ans1Strat2Step3",pt 644.0 615.0),("Ans1Strat3Step4",pt 853.0 496.0),("Ans1Strat1Step51",pt 102.0 474.0),("Ans1Strat1Step32",pt 427.0 290.0),("Ans1Strat1Step42",pt 428.0 382.0),("Ans1Strat1Step52",pt 428.0 473.0),("Ans1Strat3Step5",pt 851.0 640.0),("Ans1Strat1Step6",pt 272.0 642.0),("R1211_T03",pt 91.0 103.0),("R12_T03",pt 245.0 342.0),("R13_T03",pt 552.0 206.0),("R31_T03",pt 680.0 257.0),("R323_T03",pt 231.0 420.0),("R324_T03",pt 231.0 509.0),("R1213_T03",pt 96.0 169.0),("Ans1Strat1Step3Path",pt 260.0 271.0),("Ans1Strat1Step1Path",pt 429.0 89.0)]
+
+ans1 :: Node Bool
+ans1 = Node "Pattern_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["Pattern_Ans1Strat1Step6","Pattern_Ans1Strat2Step3","Pattern_Ans1Strat3Step5"] (NoisyMax [0,1,2,0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans1Strat :: Node String
+ans1Strat = Node "Pattern_Ans1Strat" "Solution Strategy" [("Algebraic", "Algebraic"),("Numeric1", "Numeric1"),("Numeric2", "Numeric2")] [] (CPT [0.8,0.15,4.999999999999996e-2])
+
+ans1Strat1Step11 :: Node (Maybe Bool)
+ans1Strat1Step11 = Node "Pattern_Ans1Strat1Step11" "n: pattern; G: tiles" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat","Pattern_Ans1Strat1Step1Path"] (CPT [0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step12 :: Node (Maybe Bool)
+ans1Strat1Step12 = Node "Pattern_Ans1Strat1Step12" "Start: 4; Step: 3" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat","Pattern_Ans1Strat1Step1Path"] (CPT [5.0e-3,5.0e-3,0.99,0.395,0.595,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step1Path :: Node String
+ans1Strat1Step1Path = Node "Pattern_Ans1Strat1Step1Path" "Solution Path" [("Variables", "Variables"),("No_variables", "No_variables")] [] (CPT [0.5,0.5])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "Pattern_Ans1Strat1Step2" "G = 4 + 3n" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step11","Pattern_Ans1Strat1Step12"] (NoisyMax [0,1,2,0,1,2] [0.6,0.39,1.0e-2,0.1899999999999999,0.8,1.0e-2,0.0,0.0,1.0,0.6,0.39,1.0e-2,0.1899999999999999,0.8,1.0e-2,0.0,0.0,1.0,4.999999999999449e-4,4.999999999999449e-4,0.999])
+
+ans1Strat1Step31 :: Node (Maybe Bool)
+ans1Strat1Step31 = Node "Pattern_Ans1Strat1Step31" "4+3n = 50" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step2","Pattern_Ans1Strat1Step3Path"] (CPT [0.6,0.39,1.0e-2,5.0e-3,5.0e-3,0.99,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step32 :: Node (Maybe Bool)
+ans1Strat1Step32 = Node "Pattern_Ans1Strat1Step32" "4+3n > 50" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step2","Pattern_Ans1Strat1Step3Path"] (CPT [5.0e-3,5.0e-3,0.99,0.6,0.39,1.0e-2,5.0e-3,5.0e-3,0.99,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step3Path :: Node String
+ans1Strat1Step3Path = Node "Pattern_Ans1Strat1Step3Path" "Solution Path" [("Equation", "Equation"),("Inequality", "Inequality")] [] (CPT [0.8,0.2])
+
+ans1Strat1Step41 :: Node (Maybe Bool)
+ans1Strat1Step41 = Node "Pattern_Ans1Strat1Step41" "3n = 46" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step31"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step42 :: Node (Maybe Bool)
+ans1Strat1Step42 = Node "Pattern_Ans1Strat1Step42" "3n > 46" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step32"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step51 :: Node (Maybe Bool)
+ans1Strat1Step51 = Node "Pattern_Ans1Strat1Step51" "n = 15.33" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step41"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step52 :: Node (Maybe Bool)
+ans1Strat1Step52 = Node "Pattern_Ans1Strat1Step52" "n > 15.33" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step42"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step6 :: Node (Maybe Bool)
+ans1Strat1Step6 = Node "Pattern_Ans1Strat1Step6" "Answer: \"16\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat1Step51","Pattern_Ans1Strat1Step52"] (NoisyMax [0,1,2,0,1,2] [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,4.999999999999449e-4,4.999999999999449e-4,0.999])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "Pattern_Ans1Strat2Step1" "try <n> < 16 (7,10,...)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "Pattern_Ans1Strat2Step2" "try <n> == 16 (52)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat2Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step3 :: Node (Maybe Bool)
+ans1Strat2Step3 = Node "Pattern_Ans1Strat2Step3" "Answer: \"16\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat2Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step1 :: Node (Maybe Bool)
+ans1Strat3Step1 = Node "Pattern_Ans1Strat3Step1" "Start: 7; Step: 3" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2])
+
+ans1Strat3Step2 :: Node (Maybe Bool)
+ans1Strat3Step2 = Node "Pattern_Ans1Strat3Step2" "50-7=43" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat3Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step3 :: Node (Maybe Bool)
+ans1Strat3Step3 = Node "Pattern_Ans1Strat3Step3" "43/3=14.3" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat3Step2"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step4 :: Node (Maybe Bool)
+ans1Strat3Step4 = Node "Pattern_Ans1Strat3Step4" "14.3+1=15.3" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat3Step3"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step5 :: Node (Maybe Bool)
+ans1Strat3Step5 = Node "Pattern_Ans1Strat3Step5" "Answer: \"16\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["Pattern_Ans1Strat3Step4"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+r1211_T03 :: Node Bool
+r1211_T03 = Node "R1211_T03" "Choose variables" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step11"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1213_T03 :: Node Bool
+r1213_T03 = Node "R1213_T03" "Set up linear model" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step2"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r12_T03 :: Node Bool
+r12_T03 = Node "R12_T03" "Set up algebraic equations" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step31"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r13_T03 :: Node Bool
+r13_T03 = Node "R13_T03" "Set up algebraic inequalities" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step32"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r31_T03 :: Node Bool
+r31_T03 = Node "R31_T03" "Use numerical expressions" [("Yes", True),("No", False)] ["Pattern_Ans1Strat2Step1","Pattern_Ans1Strat2Step2","Pattern_Ans1Strat3Step2","Pattern_Ans1Strat3Step3","Pattern_Ans1Strat3Step4"] (NoisyAdder [1,2,2,2,2,2] [1.0,1.0,1.0,1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r323_T03 :: Node Bool
+r323_T03 = Node "R323_T03" "Simplify by addition and subtraction" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step41","Pattern_Ans1Strat1Step42"] (NoisyAdder [1,2,2] [1.0,1.5,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r324_T03 :: Node Bool
+r324_T03 = Node "R324_T03" "Simplify by multiplication and division" [("Yes", True),("No", False)] ["Pattern_Ans1Strat1Step51","Pattern_Ans1Strat1Step52"] (NoisyAdder [1,2,2] [1.0,1.5,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+ src/Task/Network/RectangleArea.hs view
@@ -0,0 +1,54 @@+-- generated code: do not change
+module Task.Network.RectangleArea where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "RectangleArea" [node_ r1212_T02,node_ r1214_T02,node_ r12_T02,node_ r3221_T02,node_ ans1,node_ ans1Strat1Step1,node_ ans2,node_ ans2Strat1Step11,node_ ans2Strat1Step12,node_ ans2Strat1Step13,node_ ans2Strat1Step14,node_ ans2Strat1Step2,node_ ans3,node_ ans3Strat1Step1]
+
+layout :: Layout
+layout = [("Ans1",pt 24.0 119.0),("Ans2Strat1Step11",pt 296.0 82.0),("Ans2Strat1Step12",pt 406.0 81.0),("Ans1Strat1Step1",pt 145.0 45.0),("Ans2Strat1Step13",pt 524.0 81.0),("Ans3Strat1Step1",pt 365.0 282.0),("Ans2Strat1Step14",pt 650.0 81.0),("R1212_T02",pt 145.0 183.0),("R1214_T02",pt 384.0 161.0),("R3221_T02",pt 541.0 361.0),("R12_T02",pt 124.0 305.0),("Ans2",pt 689.0 280.0),("Ans3",pt 344.0 364.0),("Ans2Strat1Step2",pt 593.0 209.0)]
+
+r1212_T02 :: Node Bool
+r1212_T02 = Node "R1212_T02" "Set up geometric model" [("Yes", True),("No", False)] ["RectangleArea_Ans1Strat1Step1","RectangleArea_Ans2Strat1Step11","RectangleArea_Ans2Strat1Step12","RectangleArea_Ans2Strat1Step13","RectangleArea_Ans2Strat1Step14"] (NoisyAdder [1,1,1,1,1,1] [2.0,1.0,0.5,1.0,0.5,0.1] [0.3,0.7,0.0,1.0,0.7,0.3,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.5,0.5])
+
+r1214_T02 :: Node Bool
+r1214_T02 = Node "R1214_T02" "Set up quadratic model" [("Yes", True),("No", False)] ["RectangleArea_Ans1Strat1Step1","RectangleArea_Ans2Strat1Step11","RectangleArea_Ans2Strat1Step12","RectangleArea_Ans2Strat1Step13","RectangleArea_Ans2Strat1Step14"] (NoisyAdder [1,1,1,1,1,1] [2.0,1.0,0.5,1.0,0.5,0.1] [0.3,0.7,0.0,1.0,0.7,0.3,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.5,0.5])
+
+r12_T02 :: Node Bool
+r12_T02 = Node "R12_T02" "Set up algebraic equations" [("Yes", True),("No", False)] ["RectangleArea_Ans3Strat1Step1"] (NoisyAdder [1,1] [1.0,0.1] [0.3,0.7,0.0,1.0,0.7,0.3,0.5,0.5])
+
+r3221_T02 :: Node Bool
+r3221_T02 = Node "R3221_T02" "Expand expressions" [("Yes", True),("No", False)] ["RectangleArea_Ans3Strat1Step1"] (NoisyAdder [1,1] [1.0,0.1] [0.3,0.7,0.0,1.0,0.7,0.3,0.5,0.5])
+
+ans1 :: Node Bool
+ans1 = Node "RectangleArea_Ans1" "Q1 Answer" [("Correct", True),("Incorrect", False)] ["RectangleArea_Ans1Strat1Step1"] (CPT [5.0e-2,0.95,0.5,0.5,0.95,5.0e-2])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "RectangleArea_Ans1Strat1Step1" "Answer: \"(a+5)(a+b)\"" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] [] (CPT [0.395,1.0e-2,0.595])
+
+ans2 :: Node Bool
+ans2 = Node "RectangleArea_Ans2" "Q2 Answer" [("Correct", True),("Incorrect", False)] ["RectangleArea_Ans2Strat1Step2"] (CPT [5.0e-2,0.95,0.5,0.5,0.95,5.0e-2])
+
+ans2Strat1Step11 :: Node (Maybe Bool)
+ans2Strat1Step11 = Node "RectangleArea_Ans2Strat1Step11" "a^2" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] [] (CPT [0.29,1.0e-2,0.7])
+
+ans2Strat1Step12 :: Node (Maybe Bool)
+ans2Strat1Step12 = Node "RectangleArea_Ans2Strat1Step12" "5a" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] [] (CPT [0.29,1.0e-2,0.7])
+
+ans2Strat1Step13 :: Node (Maybe Bool)
+ans2Strat1Step13 = Node "RectangleArea_Ans2Strat1Step13" "ab" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] [] (CPT [0.29,1.0e-2,0.7])
+
+ans2Strat1Step14 :: Node (Maybe Bool)
+ans2Strat1Step14 = Node "RectangleArea_Ans2Strat1Step14" "5b" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] [] (CPT [0.29,1.0e-2,0.7])
+
+ans2Strat1Step2 :: Node (Maybe Bool)
+ans2Strat1Step2 = Node "RectangleArea_Ans2Strat1Step2" "Answer: \"a^2+5a+ab+5b\"" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] ["RectangleArea_Ans2Strat1Step11","RectangleArea_Ans2Strat1Step12","RectangleArea_Ans2Strat1Step13","RectangleArea_Ans2Strat1Step14"] (NoisyMax [0,1,2,0,1,2,0,1,2,0,1,2] [0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4000000000000001,0.3,0.0,0.0,1.0,0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4000000000000001,0.3,0.0,0.0,1.0,0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4000000000000001,0.3,0.0,0.0,1.0,0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4000000000000001,0.3,0.0,0.0,1.0,9.00000000000345e-5,9.99999999995449e-6,0.9999])
+
+ans3 :: Node Bool
+ans3 = Node "RectangleArea_Ans3" "Q3 Answer" [("Correct", True),("Incorrect", False)] ["RectangleArea_Ans3Strat1Step1"] (CPT [5.0e-2,0.95,0.5,0.5,0.95,5.0e-2])
+
+ans3Strat1Step1 :: Node (Maybe Bool)
+ans3Strat1Step1 = Node "RectangleArea_Ans3Strat1Step1" "Answer: \"(a+5)(a+b)=a^2+5a+ab+5b\"" [("Incorrect", Just False),("Not_taken", Nothing),("Correct", Just True)] ["RectangleArea_Ans2Strat1Step2","RectangleArea_Ans1Strat1Step1"] (NoisyMax [0,1,2,0,1,2] [0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4,0.3,0.0,0.0,1.0,0.6499999999999999,1.000000000000001e-2,0.34,0.2999999999999998,0.4,0.3,0.0,0.0,1.0,9.000000000000119e-4,9.999999999998899e-5,0.999])
+
+ src/Task/Network/StudentModel.hs view
@@ -0,0 +1,75 @@+-- generated code: do not change
+module Task.Network.StudentModel where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "StudentModel" [node_ r,node_ r1,node_ r11,node_ r12,node_ r121,node_ r1211,node_ r1212,node_ r1213,node_ r1214,node_ r1215,node_ r13,node_ r3,node_ r31,node_ r32,node_ r321,node_ r322,node_ r3221,node_ r3222,node_ r3223,node_ r323,node_ r324]
+
+layout :: Layout
+layout = [("R1",pt 77.0 54.0),("R1211",pt 51.0 216.0),("R12",pt 168.0 113.0),("R13",pt 249.0 118.0),("R11",pt 58.0 118.0),("R3",pt 405.0 57.0),("R31",pt 408.0 120.0),("R32",pt 529.0 122.0),("R",pt 329.0 6.0),("R322",pt 459.0 191.0),("R3221",pt 400.0 265.0),("R323",pt 567.0 184.0),("R324",pt 675.0 184.0),("R321",pt 377.0 196.0),("R121",pt 157.0 192.0),("R1212",pt 64.0 261.0),("R1213",pt 152.0 265.0),("R1214",pt 224.0 260.0),("R1215",pt 298.0 233.0),("R3222",pt 496.0 262.0),("R3223",pt 618.0 268.0)]
+
+r :: Node Bool
+r = Node "R" "Relations" [("Yes", True),("No", False)] [] (CPT [0.5,0.5])
+
+r1 :: Node Bool
+r1 = Node "R1" "Set up expressions, equations and inequalities" [("Yes", True),("No", False)] ["R"] (CPT [0.6,0.4,0.4,0.6])
+
+r11 :: Node Bool
+r11 = Node "R11" "Set up numerical expressions" [("Yes", True),("No", False)] ["R1"] (CPT [0.6,0.4,0.4,0.6])
+
+r12 :: Node Bool
+r12 = Node "R12" "Set up algebraic equations" [("Yes", True),("No", False)] ["R1"] (CPT [0.6,0.4,0.4,0.6])
+
+r121 :: Node Bool
+r121 = Node "R121" "Set up algebraic expressions" [("Yes", True),("No", False)] ["R12"] (CPT [0.6,0.4,0.4,0.6])
+
+r1211 :: Node Bool
+r1211 = Node "R1211" "Choose variables" [("Yes", True),("No", False)] ["R121"] (CPT [0.6,0.4,0.4,0.6])
+
+r1212 :: Node Bool
+r1212 = Node "R1212" "Set up geometric model" [("Yes", True),("No", False)] ["R121"] (CPT [0.6,0.4,0.4,0.6])
+
+r1213 :: Node Bool
+r1213 = Node "R1213" "Set up linear model" [("Yes", True),("No", False)] ["R121"] (CPT [0.6,0.4,0.4,0.6])
+
+r1214 :: Node Bool
+r1214 = Node "R1214" "Set up quadratic model" [("Yes", True),("No", False)] ["R121"] (CPT [0.6,0.4,0.4,0.6])
+
+r1215 :: Node Bool
+r1215 = Node "R1215" "Set up exponential model" [("Yes", True),("No", False)] ["R121"] (CPT [0.6,0.4,0.4,0.6])
+
+r13 :: Node Bool
+r13 = Node "R13" "Set up algebraic inequalities" [("Yes", True),("No", False)] ["R1"] (CPT [0.6,0.4,0.4,0.6])
+
+r3 :: Node Bool
+r3 = Node "R3" "Simplify algebraic expressions and solve equations" [("Yes", True),("No", False)] ["R"] (CPT [0.6,0.4,0.4,0.6])
+
+r31 :: Node Bool
+r31 = Node "R31" "Use numerical expressions" [("Yes", True),("No", False)] ["R3"] (CPT [0.6,0.4,0.4,0.6])
+
+r32 :: Node Bool
+r32 = Node "R32" "Solve equations" [("Yes", True),("No", False)] ["R3"] (CPT [0.6,0.4,0.4,0.6])
+
+r321 :: Node Bool
+r321 = Node "R321" "Substitute" [("Yes", True),("No", False)] ["R32"] (CPT [0.6,0.4,0.4,0.6])
+
+r322 :: Node Bool
+r322 = Node "R322" "Simplify expressions" [("Yes", True),("No", False)] ["R32"] (CPT [0.6,0.4,0.4,0.6])
+
+r3221 :: Node Bool
+r3221 = Node "R3221" "Expand expressions" [("Yes", True),("No", False)] ["R322"] (CPT [0.6,0.4,0.4,0.6])
+
+r3222 :: Node Bool
+r3222 = Node "R3222" "Divide out common factors" [("Yes", True),("No", False)] ["R322"] (CPT [0.6,0.4,0.4,0.6])
+
+r3223 :: Node Bool
+r3223 = Node "R3223" "Combine like terms" [("Yes", True),("No", False)] ["R322"] (CPT [0.6,0.4,0.4,0.6])
+
+r323 :: Node Bool
+r323 = Node "R323" "Simplify by addition and subtraction" [("Yes", True),("No", False)] ["R32"] (CPT [0.6,0.4,0.4,0.6])
+
+r324 :: Node Bool
+r324 = Node "R324" "Simplify by multiplication and division" [("Yes", True),("No", False)] ["R32"] (CPT [0.6,0.4,0.4,0.6])
+
+ src/Task/Network/TheatreRate.hs view
@@ -0,0 +1,87 @@+-- generated code: do not change
+module Task.Network.TheatreRate where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "TheatreRate" [node_ r1211_T06,node_ r1213_T06,node_ r121_T06,node_ r12_T06,node_ r13_T06,node_ r31_T06,node_ r323_T06,node_ r324_T06,node_ ans2,node_ ans2Strat,node_ ans2Strat1Step1,node_ ans2Strat1Step21,node_ ans2Strat1Step22,node_ ans2Strat1Step3,node_ ans2Strat1Step41,node_ ans2Strat1Step42,node_ ans2Strat1Step4Path,node_ ans2Strat1Step51,node_ ans2Strat1Step52,node_ ans2Strat1Step61,node_ ans2Strat1Step62,node_ ans2Strat1Step7,node_ ans2Strat2Step1,node_ ans2Strat2Step2,node_ ans2Strat2Step3]
+
+layout :: Layout
+layout = [("Ans2Strat1Step21",pt 47.0 209.0),("Ans2Strat2Step1",pt 536.0 102.0),("Ans2Strat1Step22",pt 342.0 206.0),("Ans2Strat1Step42",pt 345.0 371.0),("Ans2Strat1Step52",pt 348.0 479.0),("Ans2Strat1Step62",pt 342.0 596.0),("Ans2Strat2Step2",pt 541.0 390.0),("Ans2Strat2Step3",pt 538.0 699.0),("Ans2",pt 343.0 758.0),("Ans2Strat1Step1",pt 188.0 102.0),("R1211_T06",pt 372.0 132.0),("R1213_T06",pt 190.0 197.0),("Ans2Strat1Step41",pt 50.0 365.0),("Ans2Strat1Step7",pt 197.0 705.0),("Ans2Strat1Step51",pt 48.0 472.0),("Ans2Strat1Step61",pt 46.0 579.0),("R12_T06",pt 187.0 430.0),("R13_T06",pt 451.0 452.0),("R323_T06",pt 181.0 509.0),("R324_T06",pt 182.0 587.0),("Ans2Strat",pt 360.0 14.0),("R31_T06",pt 580.0 208.0),("R121_T06",pt 443.0 206.0),("Ans2Strat1Step4Path",pt 202.0 365.0),("Ans2Strat1Step3",pt 201.0 287.0)]
+
+r1211_T06 :: Node Bool
+r1211_T06 = Node "R1211_T06" "Choose variables" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step1"] (NoisyAdder [1,2] [1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r1213_T06 :: Node Bool
+r1213_T06 = Node "R1213_T06" "Set up linear model" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step21","TheatreRate_Ans2Strat1Step22"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r121_T06 :: Node String
+r121_T06 = Node "R121_T06" "Set up numerical expressions" [("State0", "State0"),("State1", "State1")] ["TheatreRate_Ans2Strat2Step1","TheatreRate_Ans2Strat2Step2"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r12_T06 :: Node Bool
+r12_T06 = Node "R12_T06" "Set up algebraic equations" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step41"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r13_T06 :: Node Bool
+r13_T06 = Node "R13_T06" "Set up algebraic inequalities" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step42"] (NoisyAdder [1,2] [1.0,0.1] [0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r31_T06 :: Node String
+r31_T06 = Node "R31_T06" "Use numerical expressions" [("State0", "State0"),("State1", "State1")] ["TheatreRate_Ans2Strat2Step1","TheatreRate_Ans2Strat2Step2"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+r323_T06 :: Node Bool
+r323_T06 = Node "R323_T06" "Simplify by addition and subtraction" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step51","TheatreRate_Ans2Strat1Step52"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.5,0.5])
+
+r324_T06 :: Node Bool
+r324_T06 = Node "R324_T06" "Simplify by multiplication and division" [("Yes", True),("No", False)] ["TheatreRate_Ans2Strat1Step61","TheatreRate_Ans2Strat1Step62"] (NoisyAdder [1,2,2] [1.0,1.0,0.1] [0.6,0.4,0.2,0.8,0.0,1.0,0.6,0.4,0.2,0.8,0.0,1.0,0.5,0.5])
+
+ans2 :: Node Bool
+ans2 = Node "TheatreRate_Ans2" "Q2 Answer" [("Correct", True),("Incorrect", False)] ["TheatreRate_Ans2Strat2Step3","TheatreRate_Ans2Strat1Step7"] (NoisyMax [0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,9.999999999999998e-2,0.9])
+
+ans2Strat :: Node String
+ans2Strat = Node "TheatreRate_Ans2Strat" "Q2 Solution Strategy" [("Algebraic", "Algebraic"),("Numeric", "Numeric")] [] (CPT [0.71,0.29])
+
+ans2Strat1Step1 :: Node (Maybe Bool)
+ans2Strat1Step1 = Node "TheatreRate_Ans2Strat1Step1" "n - number of shows; p - price" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat"] (CPT [0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step21 :: Node (Maybe Bool)
+ans2Strat1Step21 = Node "TheatreRate_Ans2Strat1Step21" "R1: p=30+4s" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step22 :: Node (Maybe Bool)
+ans2Strat1Step22 = Node "TheatreRate_Ans2Strat1Step22" "R2: p=8s" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step3 :: Node (Maybe Bool)
+ans2Strat1Step3 = Node "TheatreRate_Ans2Strat1Step3" "p=30+4s ? 8s" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step21","TheatreRate_Ans2Strat1Step22"] (CPT [0.9,9.5e-2,5.0e-3,9.5e-2,0.9,5.0e-3,5.0e-3,5.0e-3,0.99,9.5e-2,0.9,5.0e-3,4.5e-2,0.95,5.0e-3,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step41 :: Node (Maybe Bool)
+ans2Strat1Step41 = Node "TheatreRate_Ans2Strat1Step41" "30+4s = 8s" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step3","TheatreRate_Ans2Strat1Step4Path"] (CPT [0.7,0.29,1.0e-2,5.0e-3,5.0e-3,0.99,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step42 :: Node (Maybe Bool)
+ans2Strat1Step42 = Node "TheatreRate_Ans2Strat1Step42" "30+4s < 8s" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step3","TheatreRate_Ans2Strat1Step4Path"] (CPT [5.0e-3,5.0e-3,0.99,0.6,0.39,1.0e-2,5.0e-3,5.0e-3,0.99,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step4Path :: Node String
+ans2Strat1Step4Path = Node "TheatreRate_Ans2Strat1Step4Path" "Solution Path" [("Equation", "Equation"),("Inequality", "Inequality")] [] (CPT [0.71,0.29])
+
+ans2Strat1Step51 :: Node (Maybe Bool)
+ans2Strat1Step51 = Node "TheatreRate_Ans2Strat1Step51" "4s = 30" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step41"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step52 :: Node (Maybe Bool)
+ans2Strat1Step52 = Node "TheatreRate_Ans2Strat1Step52" "4s > 30" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step42"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step61 :: Node (Maybe Bool)
+ans2Strat1Step61 = Node "TheatreRate_Ans2Strat1Step61" "s=7,5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step51"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step62 :: Node (Maybe Bool)
+ans2Strat1Step62 = Node "TheatreRate_Ans2Strat1Step62" "s > 7,5" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step52"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat1Step7 :: Node (Maybe Bool)
+ans2Strat1Step7 = Node "TheatreRate_Ans2Strat1Step7" "Answer: \"8\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat1Step61","TheatreRate_Ans2Strat1Step62"] (NoisyMax [0,1,2,0,1,2] [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,0.0,0.0,1.0,4.999999999999449e-4,4.999999999999449e-4,0.999])
+
+ans2Strat2Step1 :: Node (Maybe Bool)
+ans2Strat2Step1 = Node "TheatreRate_Ans2Strat2Step1" "Try <n> != 8" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2])
+
+ans2Strat2Step2 :: Node (Maybe Bool)
+ans2Strat2Step2 = Node "TheatreRate_Ans2Strat2Step2" "Try <n> == 8" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat2Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans2Strat2Step3 :: Node (Maybe Bool)
+ans2Strat2Step3 = Node "TheatreRate_Ans2Strat2Step3" "Answer: \"8\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["TheatreRate_Ans2Strat2Step2"] (CPT [0.8,0.19,1.0e-2,0.39,0.6,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ src/Task/Network/VPattern.hs view
@@ -0,0 +1,57 @@+-- generated code: do not change
+module Task.Network.VPattern where
+
+import Bayes.Network
+import Bayes.SVG
+
+network :: Network ()
+network = makeNetwork "VPattern" [node_ r1213_T07,node_ r3221_T08,node_ ans1,node_ ans1Strat,node_ ans1Strat1Step1,node_ ans1Strat1Step2,node_ ans1Strat2Step1,node_ ans1Strat2Step2,node_ ans1Strat3Step1,node_ ans1Strat3Step2,node_ ans1Strat3Step3,node_ ans1Strat3Step4,node_ ans1Strat4Step1,node_ ans1Strat4Step2,node_ ans1Strat4Step3]
+
+layout :: Layout
+layout = [("Ans1",pt 291.0 569.0),("Ans1Strat1Step1",pt 79.0 286.0),("Ans1Strat1Step2",pt 76.0 405.0),("Ans1Strat",pt 311.0 65.0),("Ans1Strat2Step1",pt 235.0 289.0),("Ans1Strat2Step2",pt 234.0 396.0),("Ans1Strat3Step1",pt 371.0 162.0),("Ans1Strat3Step2",pt 373.0 262.0),("Ans1Strat3Step3",pt 369.0 360.0),("Ans1Strat3Step4",pt 369.0 460.0),("R1213_T07",pt 108.0 518.0),("R3221_T08",pt 490.0 530.0),("Ans1Strat4Step1",pt 516.0 162.0),("Ans1Strat4Step3",pt 520.0 441.0),("Ans1Strat4Step2",pt 517.0 291.0)]
+
+r1213_T07 :: Node Bool
+r1213_T07 = Node "R1213_T07" "Set up linear model" [("Yes", True),("No", False)] ["VPattern_Ans1Strat1Step2","VPattern_Ans1Strat2Step2","VPattern_Ans1Strat3Step3","VPattern_Ans1Strat4Step3"] (NoisyAdder [1,2,2,2,2] [1.0,1.0,1.0,1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.8,0.2,0.4,0.6,0.0,1.0,0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+r3221_T08 :: Node Bool
+r3221_T08 = Node "R3221_T08" "Expand expressions" [("Yes", True),("No", False)] ["VPattern_Ans1Strat3Step4"] (NoisyAdder [1,2] [1.0,0.1] [0.7,0.3,0.3,0.7,0.0,1.0,0.5,0.5])
+
+ans1 :: Node Bool
+ans1 = Node "VPattern_Ans1" "Final Answer" [("Correct", True),("Incorrect", False)] ["VPattern_Ans1Strat1Step2","VPattern_Ans1Strat2Step2","VPattern_Ans1Strat3Step4","VPattern_Ans1Strat4Step3"] (NoisyMax [0,1,2,0,1,2,0,1,2,0,1,2] [0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,0.8,0.2,9.999999999999998e-2,0.9,0.0,1.0,6.999999999999995e-2,0.93])
+
+ans1Strat :: Node String
+ans1Strat = Node "VPattern_Ans1Strat" "Solution Strategy" [("Algebraic1", "Algebraic1"),("Algebraic2", "Algebraic2"),("Algebraic3", "Algebraic3"),("Algebraic4", "Algebraic4")] [] (CPT [0.37,0.37,0.12,0.14])
+
+ans1Strat1Step1 :: Node (Maybe Bool)
+ans1Strat1Step1 = Node "VPattern_Ans1Strat1Step1" "center:1 + side:R + side:R" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat"] (CPT [0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat1Step2 :: Node (Maybe Bool)
+ans1Strat1Step2 = Node "VPattern_Ans1Strat1Step2" "Answer: \"N=1+2R\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat1Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step1 :: Node (Maybe Bool)
+ans1Strat2Step1 = Node "VPattern_Ans1Strat2Step1" "side1: R + side2: R+1" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99])
+
+ans1Strat2Step2 :: Node (Maybe Bool)
+ans1Strat2Step2 = Node "VPattern_Ans1Strat2Step2" "Answer: \"N=1+2R\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat2Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step1 :: Node (Maybe Bool)
+ans1Strat3Step1 = Node "VPattern_Ans1Strat3Step1" "step1: 3 dots" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.595,0.395,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step2 :: Node (Maybe Bool)
+ans1Strat3Step2 = Node "VPattern_Ans1Strat3Step2" "stepR: 2*(R-1) dots" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat3Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step3 :: Node (Maybe Bool)
+ans1Strat3Step3 = Node "VPattern_Ans1Strat3Step3" "N=3+2(R-1)" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat3Step2"] (CPT [0.6,0.39,1.0e-2,0.19,0.8,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat3Step4 :: Node (Maybe Bool)
+ans1Strat3Step4 = Node "VPattern_Ans1Strat3Step4" "Answer: \"N=1+2R\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat3Step3"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step1 :: Node (Maybe Bool)
+ans1Strat4Step1 = Node "VPattern_Ans1Strat4Step1" "step0: 1 dot" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat"] (CPT [5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,5.0e-3,5.0e-3,0.99,0.495,0.495,1.0e-2])
+
+ans1Strat4Step2 :: Node (Maybe Bool)
+ans1Strat4Step2 = Node "VPattern_Ans1Strat4Step2" "step: +2 dots" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat4Step1"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ans1Strat4Step3 :: Node (Maybe Bool)
+ans1Strat4Step3 = Node "VPattern_Ans1Strat4Step3" "Answer: \"N=1+2R\"" [("Correct", Just True),("Incorrect", Just False),("Not_taken", Nothing)] ["VPattern_Ans1Strat4Step2"] (CPT [0.7,0.29,1.0e-2,0.29,0.7,1.0e-2,5.0e-3,5.0e-3,0.99])
+
+ src/Task/Pattern/Assess.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.Pattern.Assess where++import Data.Monoid+import Domain.Math.Data.Relation+import Recognize.Data.Approach+import Bayes.Evidence+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.RuleId+import Recognize.Data.Diagnosis as S+import Recognize.Data.Step+import Recognize.Expr.Symbols+import Recognize.Model.Assess+import Recognize.Model.Connectives+import Recognize.Model.EvidenceBuilder+import Task.Network.Pattern++assess' :: Diagnosis -> Evidence+assess' sd =+  stringNode (apprtostring appr) ans1Strat <> --check which approach has been used+  answerCorrect 16 attrs ans1 <> --check if the answer is indeed 16+  generateEvidence buildStepsEvidence appr attrs+  where+    attrs = map (snd . getValue) $ steps sd+    appr  = approach sd+    apprtostring Generalizing = Just "Algebraic"+    apprtostring Numerical = Just "Numeric1"+    apprtostring (Other "Numerical2") = Just "Numeric2"+    apprtostring _         = Nothing+++buildStepsEvidence :: Approach -> EvBuilder ()+buildStepsEvidence Generalizing = stepsAGBuilder+buildStepsEvidence Numerical = stepsN1Builder+buildStepsEvidence (Other "Numerical2") = stepsN2Builder+buildStepsEvidence _             = return ()++stepsAGBuilder :: EvBuilder ()+stepsAGBuilder = do+  giveNodeAndCollect ans1Strat1Step2 $ withoutFailure (exists1 (Label "definition"))+++  stepsAG1Builder >> stepsAG2Builder++stepsAG1Builder :: EvBuilder ()+stepsAG1Builder = do+  giveNodeAndCollect ans1Strat1Step31 $ withoutFailure (exists1 (Label "equation"))++  giveNodeAndCollect ans1Strat1Step41 $ withoutFailure (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .==. wildcard) (wildcard .==. wildcard)))++  giveNodeAndCollect ans1Strat1Step51 $ withoutFailure (exists1 (ARuleR Coverup_Times_Positive (wildcard .==. wildcard) (wildcard .==. wildcard)))++  giveNodeAndCollect ans1Strat1Step6 $ implication [ FinalAnswer wildcard ] [ FinalAnswer 16]++stepsAG2Builder :: EvBuilder ()+stepsAG2Builder = do+  giveNodeAndCollect ans1Strat1Step32 $ withoutFailure (exists1 (Label "inequation"))++  giveNodeAndCollect ans1Strat1Step42 $ withoutFailure (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .>. wildcard) (wildcard .>. wildcard)))++  giveNodeAndCollect ans1Strat1Step52 $ withoutFailure (exists1 (ARuleR Coverup_Times_Positive (wildcard .>. wildcard) (wildcard .>. wildcard)))++  giveNodeAndCollect ans1Strat1Step6 $ implication [ FinalAnswer wildcard ] [ FinalAnswer 16]++stepsN1Builder :: EvBuilder ()+stepsN1Builder = do+  giveNodeAndCollectAllKnown ans1Strat2Step1 [exists1 (NExpr 7), exists1 (NExpr 10), exists1 (NExpr 13), exists1 (NExpr 16)]++  giveNodeAndCollect ans1Strat2Step2 $ exists1 (NExpr 52) ==> (failOnCommonMistake <?>> success)++  giveNodeAndCollect ans1Strat2Step3 $ implication [ FinalAnswer wildcard ] [ FinalAnswer 16 ]+++stepsN2Builder :: EvBuilder ()+stepsN2Builder = do+  giveNodeAndCollect ans1Strat3Step2 $ withoutFailure (exists1 (Label "subtract"))++  giveNodeAndCollect ans1Strat3Step3 $ withoutFailure (exists1 (Label "divide"))++  giveNodeAndCollect ans1Strat3Step4 $ withoutFailure (exists1 (Label "increase"))++  giveNodeAndCollect ans1Strat3Step5 $ implication [ FinalAnswer wildcard ] [ FinalAnswer 16 ]
+ src/Task/Pattern/Recognizer.hs view
@@ -0,0 +1,263 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.Pattern.Recognizer (pattern) where++import Control.Arrow+import Control.Applicative (empty,many)+import Control.Monad (guard, msum)+import Data.Maybe+import Util.List+import Util.Monad+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.Math+import Recognize.Data.MathStoryProblem+import Recognize.Data.MathParserOptions+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.Approach+import Recognize.Data.Step+import Recognize.Data.StringLexer+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.Recognizer+import Recognize.Strategy.Applications+import Recognize.SubExpr.Recognizer+import Recognize.SubExpr.SEParser+import Recognize.SubExpr.Symbols hiding (ltSymbol)+import Task.Pattern.Assess+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Ideas.Common.Id+import Ideas.Common.Rewriting+import Ideas.Text.OpenMath.Dictionary.Relation1+import Task.Network.Pattern+import Bayes.Evidence ( evidenceOfAbsence )++pattern :: MathStoryProblem+pattern = mathStoryProblem+   { problemId   = newId "pattern"+   , analyzers   = [(newId "04", ana)]+   , inputFile   = Just "input/pattern.csv"+   , networkFile = Just "networks/Pattern.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { parser     = mathParser mathParserOptions { functionCallWhitelist = "uU" } . stringLexerOutput+      , recognizer = seRecognizer pDiagnosis . mathParserOutput . modifyInput+      , collector  = evidenceOfAbsence ans1 False . assess'+      }+++-- Somewhat of a hack, since the lexer/parser should correctly handle whitelisting of variables+-- Should be fixed once pilots are finished+modifyInput :: MathParserOutput -> MathParserOutput+modifyInput (MathParserOutput mpo che) = MathParserOutput (map math mpo) che+  where+    math (M t ethe) = M t $ fmap remVar ethe+    -- For this exercise we wish to remove expressions such as 15*th, which could have been written as 15th+    -- We are fairly certain that in this exercise the variables in singular expressions such as the one above+    -- are meaningless and may be removed. If this appears not the be the case, then this function should be removed.+    remVar (e :*: Var _) = e+    remVar e = e++pDiagnosis :: SEParser Diagnosis+pDiagnosis = do+  (appr, st) <- pSteps+  let sd = newDiagnosis appr st+      -- exprs = rights (map (getResult . getMath) st)+      -- exprAsString = concatMap show exprs+  return sd++pSteps :: SEParser (Approach, [Step])+pSteps = do+  (ap,e,st,sk) <- choice'+    [+      (\(e,st,sk) -> (Numerical,e,st,sk))    <$> withGuard (\(_,xs,_) -> not $ null xs) pStepsNumerical+    , (\(e,st,sk) -> ((Other "Numerical2"),e,st,sk))    <$> withGuard (\(_,xs,_) -> not $ null xs) pStepsRecursive+    , (\(e,st,sk) -> (Generalizing,e,st,sk)) <$> pStepsGeneralizing+    ]+  fa_st <- pFinalAnswer sk e+  let ss = st ++ maybeToList fa_st+  guard (length ss >= 1)+  return (ap,ss)++-- | This is a counting strategy+--+-- Usually starts at 4,7 or 10 and then continuously adds 3 (unless a mistake is made)+pStepsNumerical :: SEParser (Expr, [Step],[Math])+pStepsNumerical = do+      pInOrderAll [ const $ withGuard (\(_, xs) -> length xs >= 3) $ pNumAndVals 4 ]++-- | Parses the correct values in combination with numbers+pNumAndVals :: Expr -> SEParser (Expr, [Step])+pNumAndVals e = do+  me <- option $ pNumAndVal e+  case me of+    Nothing -> return (e,[])+    Just (e',ss) -> second (ss:) <$> pNumAndVals e'+  where+    pNumAndVal ex = do+      (b',attr,math) <- choice+        [ do+          -- No numbers, so:+          -- 4+          -- 7+          -- 10+          -- ..+          m_a <- skip+          a <- getExpr m_a+          (b',attr) <- isVal ex a+          return (b', attr, m_a)+        , do+          -- 1 == 4+          -- 2 == 7+          -- 3 == 10+          -- ..+          meq <- skip+          (a :==: b) <- getEq meq+          guard (isNat a)+          (b',attr) <- isVal ex b+          return (b', attr, meq)+        , do+          -- 1 4+          -- 2 7+          -- 3 10+          -- ..+          m_a <- skip+          a <- getExpr m_a+          guard (isNat a)+          m_b <- skip+          b <- getExpr m_b+          (b',attr) <- isVal ex b+          return (b', attr, m_b)]+      return (b', valStep attr math)++isVal :: Expr -> Expr -> SEParser (Expr, [Attribute])+isVal e1 e2 =+  maybeToParse $ msum+    [ do+      let diff = nf $ (e2 - e1) / 3+      guard $ isNat diff && diff <= 5 && not (e1 == 4 && e2 == 16)+      return (e2,[NExpr e2])+    , do+      -- Added 4 instead of 3+      let diff = nf $ (e2 - e1) / 4+      guard $ isNat diff && diff <= 5 && not (e1 == 4 && e2 == 16)+      return (e2,[CommonMistake])+    , do+      -- Added 2 instead of 3+      let diff = nf $ (e2 - e1) / 2+      guard $ isNat diff && diff <= 5 && not (e1 == 4 && e2 == 16)+      return (e2,[CommonMistake])+    , do+      -- 21,24,27,54+      -- Sometimes halfway they multiply by two+      guard $ nf (e2 / e1) == 2+      return (e2,[CommonMistake])+    ]++valStep :: [Attribute] -> Math -> Step+valStep attr m = Step (newId "num") (m,attr) []++-- | Calculates the answer by dividing the number of tiles to go divided by the number of tiles that are added each pattern increase+pStepsRecursive :: SEParser (Expr, [Step],[Math])+pStepsRecursive = do+  n <- getInputSize+  pLog $ "Size: " ++ show n+  pInOrder+    [ \_ -> pMatchSubSteps rexpr2+    , \m -> case m of+        (Just (a,_)) -> pMatchSubSteps $ rexpr3_a a+        Nothing -> pMatchSubSteps rexpr3_b+    , \_ -> pMatchSubSteps rexpr4+    ]+    where+      rexpr2 = lbl "subtract" $ newMagicNat - newMagicNat+      rexpr3_a e = lbl "divide" $ e / (3 <!> 2 <!> 4)+      rexpr3_b = lbl "divide" $ sub $ ((46 <?> 43 <?> 40) <!> newMagicNat) / (3 <!> 2 <!> 4)+      rexpr4 = lbl "increase" $ lt "u" newMagicNat $ \u -> sub (u + sim (16 - u))++-- | Linearly solves the answer+pStepsGeneralizing :: SEParser (Expr, [Step],[Math])+pStepsGeneralizing = do+  pInOrder+    [ \_ -> pMatchSubSteps gstep1+    , \_ -> do+      -- Ensures only one input will be consumed+      modify $ \st -> st+         { optTraverse = False+         , optIterate  = False+         , inputType   = Just [Linear, Definition]+         }+      resetAfter (pMatchSubSteps gstep2_def)+    , \_ -> do+      -- 4+3x = 50+      let+      modify $ \st -> st { inputType = Just [LinearWithType EqualTo] }+      res <- resetAfter (pMatchSubSteps gstep2_eq)+      return res+    , \_ -> do+      -- 4+3x < 50+      modify $ \st -> st { inputType = Just [LinearWithType LessThan, LinearWithType GreaterThan] }+      res <- resetAfter (pMatchSubSteps gstep2_ineq)+      return res+    , \mres -> do+      pLog ("equation succeeded: " ++ show mres)+      mrel <- case mres of+                  Just (e,st) -> do+                    (e1,e2) <- getBinary e+                    let rel = e1 .==. e2+                    math <- maybeToParse $ safeLast $ getMaths st+                    return $ Just (rel,math)+                  Nothing -> return Nothing+      pLog $ "found rel: " ++ show mrel+      res <- pSolveLinear mrel+      guard (length (snd res) >= 2)+      return $ first rightHandSide res+    , \res -> case res of+      Nothing -> empty+      Just (e,_) -> pMatchSubSteps (gstep3 e)+    ]+    where+      gstep1 = 7 <?> (lbl "add 3 tiles" 3) + 4+      gstep2 = ((4 <!> 7) + 3*newMagicVar) <!> newMagicNat + 3*newMagicVar <!>  7*newMagicVar+      gstep2_def = lbl "definition" gstep2+      gstep2_eq = lbl "equation" (gstep2 <&> (50 <!> newMagicNat))+      gstep2_ineq = lbl "inequation" (gstep2 <&> (50 <!> newMagicNat))+      gstep3 r = (lbl "pattern" $ (16 <?> ceilingExpr (nf4 2 r)) <!> floorExpr (nf4 2 r)) <?> (lbl "solution" $ nf4 2 r)++pFinalAnswer :: [Math] -> Expr -> SEParser (Maybe Step)+pFinalAnswer skipped e = do+  pLog "pFinalAnswer"+  rest <- many skip+  let answers = catMaybes $ map mAnswer (skipped ++ rest)+  let me = closestInList (filter (\n -> isNat n && n >= 12 && n <= 20) $ e : answers) 16+  case me of+    Nothing -> pLog "empty" >> return Nothing+    Just fe -> return $ Just $ makeFAStep fe++mAnswer :: Math -> Maybe Expr+mAnswer m =+  msum+    [ do+      (x :==: y) <- getEq m+      guard (isVar x && isNat y)+      return y+    , do+      n <- getExpr m+      guard (isNat n)+      return n+    ]
+ src/Task/RectangleArea.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.RectangleArea (rectangleArea) where++import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Semigroup+import Domain.Math.Expr+import Ideas.Common.Id+import Recognize.Data.Approach (Approach (Algebraic))+import Recognize.Data.Attribute+import Recognize.Data.MathStoryProblem+import Recognize.Data.Math+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Parsing.Derived+import Recognize.Parsing.Interpretation+import Recognize.Recognizer+import Recognize.Data.MathParserOptions+import Util.Expr+import Bayes.Evidence+import Recognize.Data.Step+import Task.Network.RectangleArea++rectangleArea :: MathStoryProblem+rectangleArea = mathStoryProblem+   { problemId   = newId "rectanglearea"+   , analyzers   = [ (newId "06a", ana6a)+                   , (newId "06b", ana6b)+                   , (newId "06c", ana6c)+                   ]+   , inputFile   = Just "input/rectanglearea.csv"+   , networkFile = Just "networks/RectangleArea.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer { parser = mathParser mathParserOptions {convertToLowercase = True} . stringLexerOutput }+   ana6a = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ1) . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False . mconcat . map assessStep1 . steps+      }+   ana6b = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ2) . mathParserOutput+      , collector  = evidenceOfAbsence ans2 False . mconcat . map assessStep2 . steps+      }+   ana6c = ana+      { recognizer = defaultRecognizer (pDiagnose pTaskQ3) . mathParserOutput+      , collector  = evidenceOfAbsence ans3 False . mconcat . map assessStep3 . steps+      }++--finalSteps :: [Id]+--finalSteps = map newId ["Big rectangle"]++assessStep1 :: Step -> Evidence+assessStep1 s | getId s == newId "Big rectangle" = ans1Strat1Step1 .== Just stepCorrect <> ans1 .== stepCorrect+              | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)++assessStep2 :: Step -> Evidence+assessStep2 s | getId s == newId "TopLeft"     = ans2Strat1Step11 .== Just stepCorrect+              | getId s == newId "TopRight"    = ans2Strat1Step12 .== Just stepCorrect+              | getId s == newId "BottomLeft"  = ans2Strat1Step13 .== Just stepCorrect+              | getId s == newId "BottomRight" = ans2Strat1Step14 .== Just stepCorrect+              | getId s == newId "Big rectangle sum" = ans2Strat1Step2 .== Just stepCorrect <> ans2 .== stepCorrect+              | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)++assessStep3 :: Step -> Evidence+assessStep3 s+   | getId s == newId "Big rectangle equation" = ans3Strat1Step1 .== Just stepCorrect <> ans3 .== stepCorrect+   | otherwise = mempty+ where+   stepCorrect = not (hasMistakes s)++-- | @rectangleAreaByParts xs ys@ represents correct and erroneous representations of a rectangle.+rectangleAreaByParts :: [Interpretation]  -- ^ expressions of length on x axis+                     -> [Interpretation]  -- ^ expressions of length on y axis+                     -> Interpretation+rectangleAreaByParts xs ys = sum'+  [    a >*< b+   <|> a >+< a >+< b >+< b <! Misconception Perimeter Area+  | a <- xs+  , b <- ys+  ]+  <|> interpret 2 >*< sum' xs >+< interpret 2 >*< sum' ys <! Misconception Perimeter Area+  <|> sum' xs >*< sum' xs <! Misconception Square Rectangle+  <|> sum' ys >*< sum' ys <! Misconception Square Rectangle++areaTL,areaTR,areaBL,areaBR :: Interpretation+areaTL = squared (interpret (Var "a"))+areaTR = interpret (5 * Var "a")+     <|> interpret (2*(5 + Var "a")) <! Misconception Perimeter Area+areaBL = interpret (Var "a" * Var "b")+     <|> interpret (2* (Var "a" + Var "b")) <! Misconception Perimeter Area+areaBR = interpret (5 * Var "b")+     <|> interpret (2 * (5 + Var "b")) <! Misconception Perimeter Area++--The rectangle as calculated in Q1+bigRectangle :: Interpretation+bigRectangle = interpret ((Var "a" + 5) * (Var "a" + Var "b"))++--The rectangle as calculated in Q2+bigRectangleSum :: Interpretation+bigRectangleSum = sum' [areaTL, areaTR, areaBL, areaBR]+           <|> sum'' [interpret 5, interpret (Var "a")] >>*<< sum'' [interpret (Var "a"), interpret (Var "b")]+           <|> rectangleAreaByParts [interpret 5, interpret (Var "a")] [interpret (Var "a"), interpret (Var "b")]+           <|> interpret (Var "a" * Var "a" + 5 * Var "b") <! Other "M3" <! IncorrectFactorization++pTaskQ1 :: InterpretationParser [Step]+pTaskQ1 = pAnywhere $ (:[]) <$> pNamedStep (newId "Big rectangle") (interpret $ wildcard "bigRectangle") bigRectangle++pTaskQ2 :: InterpretationParser [Step]+pTaskQ2 = catMaybes <$> many' (choice'+          [ Just <$> pNamedStep (newId "TopLeft") (interpret $ wildcard "tl") areaTL+          , Just <$> pNamedStep (newId "TopRight") (interpret $ wildcard "tr") areaTR+          , Just <$> pNamedStep (newId "BottomLeft") (interpret $ wildcard "bl") areaBL+          , Just <$> pNamedStep (newId "BottomRight") (interpret $ wildcard "br") areaBR+          , Just <$> pNamedStep (newId "Big rectangle sum") (interpret $ wildcard "bigRectangleSum") bigRectangleSum+          , Nothing <$ skip+          ])++pTaskQ3 :: InterpretationParser [Step]+pTaskQ3 = pAnyOf [pStepEq (newId "Big rectangle equation") bigRectangle bigRectangleSum]++pDiagnose :: InterpretationParser [Step] -> InterpretationParser Diagnosis+pDiagnose p = do addWildcardConstraint "tl" isDefinition+                 addWildcardConstraint "tr" isDefinition+                 addWildcardConstraint "br" isDefinition+                 addWildcardConstraint "bl" isDefinition+                 x <- p+                 guard (not . Prelude.null $ x)+                 return $ newDiagnosis Algebraic x
+ src/Task/TheatreRate/Assess.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Task.TheatreRate.Assess where
+
+  import Data.Monoid
+  import Domain.Math.Data.Relation
+  import Recognize.Data.Approach
+  import Bayes.Evidence
+  import Recognize.Data.Attribute hiding (Other)
+  import Recognize.Data.Diagnosis as S
+  import Recognize.Data.RuleId
+  import Recognize.Data.Step
+  import Recognize.Expr.Symbols
+  import Recognize.SubExpr.Symbols
+  import Recognize.Model.Assess
+  import Recognize.Model.Connectives
+  import Recognize.Model.EvidenceBuilder
+  import Task.Network.TheatreRate
+
+  assess' :: Diagnosis -> Evidence
+  assess' sd =
+    stringNode (apprtostring appr) ans2Strat <> --check which approach has been used
+    answerCorrect 8 attrs ans2 <> --check if the answer is indeed 8
+    generateEvidence buildStepsEvidence appr attrs
+    where attrs = map (snd . getValue) $ steps sd
+          appr  = approach sd
+          apprtostring Algebraic = Just "Algebraic"
+          apprtostring Numerical = Just "Numeric"
+          apprtostring _         = Nothing
+
+  buildStepsEvidence :: Approach -> EvBuilder ()
+  buildStepsEvidence Algebraic = stepsABuilder
+  buildStepsEvidence Numerical = stepsNBuilder
+  buildStepsEvidence _             = return ()
+
+  stepsABuilder :: EvBuilder ()
+  stepsABuilder = do
+    giveNodeAndCollect ans2Strat1Step21 $ withoutFailure (exists1 (Label "R1"))
+    giveNodeAndCollect ans2Strat1Step22 $ withoutFailure (exists1 (Label "R2"))
+    giveNodeAndCollect ans2Strat1Step3 $ withoutFailure ((exists1 (Label "setup equation")) <?>> (exists1 (Label "setup inequation")))
+    --The equality path:
+    giveNodeAndCollect ans2Strat1Step41 $ withoutFailure (exists1 (Label "setup equation"))
+    giveNodeAndCollect ans2Strat1Step51 $ withoutFailure (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .==. wildcard) (wildcard .==. wildcard)))
+    giveNodeAndCollect ans2Strat1Step61 $ withoutFailure (exists1 (ARuleR Coverup_Times_Positive (wildcard .==. wildcard) (wildcard .==. wildcard)))
+    --The inequality path:
+    --We have to think about all options regarding the symbols < and >
+    giveNodeAndCollect ans2Strat1Step42 $ withoutFailure (exists1 (Label "setup inequation"))
+    giveNodeAndCollect ans2Strat1Step52 $ withoutFailure ((exists1 (ARuleR Coverup_OneVar_Plus (wildcard .<. wildcard) (wildcard .>. wildcard))) <?>> (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .>. wildcard) (wildcard .<. wildcard)))
+      <?>> (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .>. wildcard) (wildcard .>. wildcard))) <?>> (exists1 (ARuleR Coverup_OneVar_Plus (wildcard .<. wildcard) (wildcard .<. wildcard))))
+    giveNodeAndCollect ans2Strat1Step62 $ withoutFailure ((exists1 (ARuleR Coverup_Times_Positive (wildcard .<. wildcard) (wildcard .>. wildcard))) <?>> (exists1 (ARuleR Coverup_Times_Positive (wildcard .>. wildcard) (wildcard .<. wildcard)))
+      <?>> (exists1 (ARuleR Coverup_Times_Positive (wildcard .>. wildcard) (wildcard .>. wildcard))) <?>> (exists1 (ARuleR Coverup_Times_Positive (wildcard .<. wildcard) (wildcard .<. wildcard))))
+
+    giveNodeAndCollect ans2Strat1Step7 (exists1 (FinalAnswer 8))
+
+  stepsNBuilder :: EvBuilder ()
+  stepsNBuilder = do
+    giveNodeAndCollect ans2Strat2Step1 $ withoutFailure (exists1 (LabelE "Try" newMagicNat))
+    giveNodeAndCollect ans2Strat2Step2 $ withoutFailure (exists1 (LabelE "Try" 8))
+    giveNodeAndCollect ans2Strat2Step3 (exists1 (FinalAnswer 8))
+ src/Task/TheatreRate/Recognizer.hs view
@@ -0,0 +1,203 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.TheatreRate.Recognizer (theatreRate) where++import Control.Arrow+import Control.Applicative                      (many,empty)+import Control.Monad                            (guard, msum)+import Data.Maybe+import Util.List+import Util.Monad+import Recognize.Data.Approach+import Recognize.Data.Math+import Recognize.Data.MathParserOptions+import Recognize.Data.MathParserOutput+import Recognize.Data.MathStoryProblem+import Recognize.Data.Diagnosis+import Recognize.Data.StringLexer+import Recognize.Expr.Functions+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.Recognizer+import Recognize.Strategy.Applications+import Recognize.SubExpr.Recognizer+import Recognize.SubExpr.SEParser+import Recognize.SubExpr.Symbols+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Ideas.Common.Id+import Ideas.Utils.Uniplate                     (transform)+import Ideas.Utils.Prelude+import Task.TheatreRate.Assess+import Task.Network.TheatreRate+import Bayes.Evidence ( evidenceOfAbsence )++theatreRate :: MathStoryProblem+theatreRate = mathStoryProblem+   { problemId     = newId "theatrerate"+   , processInputs = filter ((== newId "07b") . getId)+   , analyzers     = [(newId "07b", ana)]+   , inputFile     = Just "input/theatrerate.csv"+   , networkFile   = Just "networks/TheatreRate.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { parser     = mathParser mathParserOptions {multByConcatenation = False} . stringLexerOutput+      , recognizer = seRecognizer pDiagnosis . mathParserOutput . modifyInput+      , collector  = evidenceOfAbsence ans2 False . assess'+      }++-- Somewhat of a hack, since the lexer/parser should correctly handle whitelisting of variables+-- Should be fixed once pilots are finished+modifyInput :: MathParserOutput -> MathParserOutput+modifyInput (MathParserOutput mpo che) = MathParserOutput (map math mpo) che+  where+    math (M t ethe) = M t $ fmap (transform exprDiv . transform expr) ethe+    expr e = case e of+      (Var "r" :*: 1) -> Var "r1"+      (Var "r" :*: 2) -> Var "r2"+      (Var "R" :*: 1) -> Var "R1"+      (Var "R" :*: 2) -> Var "R2"+      (Var "T" :*: 1) -> Var "T1"+      (Var "T" :*: 2) -> Var "T2"+      (Var "t" :*: 1) -> Var "t1"+      (Var "t" :*: 2) -> Var "t2"+      _ -> e+    -- Also a quickfix for variables ending with a colon being recognized as division+    exprDiv e = case e of+      (Var "R1" :/: e') -> e'+      (Var "r1" :/: e') -> e'+      (Var "R2" :/: e') -> e'+      (Var "r2" :/: e') -> e'+      (Var "T1" :/: e') -> e'+      (Var "t1" :/: e') -> e'+      (Var "T2" :/: e') -> e'+      (Var "t2" :/: e') -> e'+      _ -> e++pDiagnosis :: SEParser Diagnosis+pDiagnosis = do+  (appr, st) <- pSteps+  let   sd = newDiagnosis appr st+  --    exprs = rights (map (getResult . getMath) st)+  --    exprAsString = concatMap show exprs+  return sd+++pSteps :: SEParser (Approach, [Step])+pSteps = do+  (ap,e,st,sk) <- choice+    [+      (\(e,st,sk) -> (Numerical,e,st,sk)) <$> withGuard (not . null . snd3) pStepsNumerical+    , (\(e,st,sk) -> (Algebraic,e,st,sk)) <$> withGuard (not . null . snd3) pStepsAlgebraic+    ]+  fa_st <- pFinalAnswer sk e+  let ss = st ++ maybeToList fa_st+  guard (length ss >= 1)+  return (ap,ss)++r1_def :: Expr -> Expr+r1_def s = 4*s + 30 <!> 30*s + 4 <!> 30*s++r2_def :: Expr -> Expr+r2_def s = 8*s <!> newMagicNat*s++r12_def :: Expr+r12_def = lt "s" newMagicVar $ \s -> lbl "R1" (r1_def s) <?> lbl "R2" (r2_def s)++r12_equation :: Expr+r12_equation = lbl "setup equation" $ lt "s" newMagicVar $ \s -> r1_def s <&> r2_def s++r12_inequation :: Expr+r12_inequation = lbl "setup inequation" $ lt "s" newMagicVar $ \s -> r1_def s <&> r2_def s++-- | Linearly solve the answer+pStepsAlgebraic :: SEParser (Expr,[Step],[Math])+pStepsAlgebraic =+  pInOrder+    [ \_ -> do+      -- T1: 30+4x+      -- T2: 8x+      modify $ \st -> st { inputType = Just [Expr, Definition] }+      pMatchSubSteps r12_def+    , \mres -> case mres of+        Nothing -> empty+        Just (e1,st1) -> do+          (e2,st2) <- resetAfter $ pMatchSubSteps r12_def+          -- Make sure that we didn't match the same formula twice+          guard (e1 /= e2)+          -- Returning e2 only because we have to return an Expr+          return (e2,st1++st2)+    , \_ -> do+      -- 30+4x = 8x+      modify $ \st -> st { inputType = Just [LinearWithType EqualTo] }+      res <- resetAfter (pMatchSubSteps r12_equation)+      pLog ("test: " ++ show res)+      return res+    , \_ -> do+      -- 30+4x < 8x+      modify $ \st -> st { inputType = Just [LinearWithType LessThan, LinearWithType GreaterThan] }+      res <- resetAfter (pMatchSubSteps r12_inequation)+      pLog ("test: " ++ show res)+      return res+    ,+     \mres -> do+      pLog ("equation succeeded: " ++ show mres)+      mrel <- case mres of+                  Just (e,st) -> do+                    (e1,e2) <- getBinary e+                    let rel = e1 .==. e2+                    math <- maybeToParse $ safeLast $ getMaths st+                    return $ Just (rel,math)+                  Nothing -> return Nothing+      pLog $ "found rel: " ++ show mrel+      res <- pSolveLinear mrel+      guard (length (snd res) >= 2)+      return $ first rightHandSide res+    ]++-- | Fill in some values in the equations and see where it gets you...+pStepsNumerical :: SEParser (Expr, [Step],[Math])+pStepsNumerical = do+  pLog "Numerical"+  res <- many1 (pSkipUntil $ pMatchSubSteps nexpr)+  let sts = concatMap (snd . fst) res+  let sk = concatMap snd res+  let e = fst $ fst $ head res+  return (e, sts, sk)+  where+    nexpr = lt "r" newMagicNat $ \r -> lblE "Try" r ((30 + 4*r <!> 30*r + 4 <!> 30*r) <&> 8*r)++pFinalAnswer :: [Math] -> Expr -> SEParser (Maybe Step)+pFinalAnswer skipped e = do+  pLog "pFinalAnswer"+  rest <- many skip+  let answers = mapMaybe mAnswer (skipped ++ rest)+  let me = closestInList (filter (\n -> isNat n && n >= 6 && n <= 10) $ e : answers) 8+  case me of+    Nothing -> pLog "empty" >> return Nothing+    Just fe -> return $ Just $ makeFAStep fe++mAnswer :: Math -> Maybe Expr+mAnswer m =+  msum+    [ do+      (x :==: y) <- getEq m+      guard (isVar x && isNat y)+      return y+    , do+      n <- getExpr m+      guard (isNat n)+      return n+    ]
+ src/Task/VPattern/Assess.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.VPattern.Assess where++import Data.Monoid+import Bayes.Evidence+import Recognize.Data.Approach+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.Diagnosis as S+import Recognize.Data.Step+import Recognize.Model.Assess+import Recognize.Model.Connectives+import Recognize.Model.EvidenceBuilder+import Task.Network.VPattern++assess' :: Diagnosis -> Evidence+assess' sd =+  stringNode (apprtostring appr) ans1Strat <> --check which approach has been used+  generateEvidence buildStepsEvidence appr attrs+  where attrs = map (snd . getValue) $ steps sd+        appr  = approach sd+        apprtostring Algebraic = Just "Algebraic1"+        apprtostring (Other "Algebraic2") = Just "Algebraic2"+        apprtostring (Other "Algebraic3") = Just "Algebraic3"+        apprtostring (Other "Algebraic4") = Just "Algebraic4"+        apprtostring _         = Nothing++buildStepsEvidence :: Approach -> EvBuilder ()+buildStepsEvidence Algebraic            = stepsA1Builder+buildStepsEvidence (Other "Algebraic2") = stepsA2Builder+buildStepsEvidence (Other "Algebraic3") = stepsA3Builder+buildStepsEvidence (Other "Algebraic4") = stepsA4Builder+buildStepsEvidence _                    = return ()++stepsA1Builder :: EvBuilder ()+stepsA1Builder = do+  giveNodeAndCollect ans1Strat1Step1 $ withoutFailure (exists1 (Label "A1"))++  giveNodeAndCollect ans1Strat1Step2 $ withoutFailure (exists1 (Label "S"))++  giveNodeAndCollect ans1 $ withoutFailure (exists1 (Label "S"))++stepsA2Builder :: EvBuilder ()+stepsA2Builder = do+  giveNodeAndCollect ans1Strat2Step1 $ withoutFailure (exists1 (Label "A2"))++  giveNodeAndCollect ans1Strat2Step2 $ withoutFailure (exists1 (Label "S"))++  giveNodeAndCollect ans1 $ withoutFailure (exists1 (Label "S"))++stepsA3Builder :: EvBuilder ()+stepsA3Builder = do+  giveNodeAndCollect ans1Strat3Step2 $ withoutFailure (exists1 (Label "A3_1"))++  giveNodeAndCollect ans1Strat3Step3 $ withoutFailure (exists1 (Label "A3_2"))++  giveNodeAndCollect ans1Strat3Step4 $ withoutFailure (exists1 (Label "S"))++  giveNodeAndCollect ans1 $ withoutFailure (exists1 (Label "S"))++stepsA4Builder :: EvBuilder ()+stepsA4Builder = do+  giveNodeAndCollect ans1Strat4Step2 $ withoutFailure (exists1 (Label "2"))++  giveNodeAndCollect ans1Strat4Step3 $ withoutFailure (exists1 (Label "S"))++  giveNodeAndCollect ans1 $ withoutFailure (exists1 (Label "S"))
+ src/Task/VPattern/Recognizer.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Task.VPattern.Recognizer (vPattern) where++import Control.Applicative                     (many)+import Control.Arrow                           (second)+import Control.Monad                           (guard, msum)+import Util.List+import Util.Monad+import Recognize.Data.Approach+import Recognize.Data.Attribute hiding (Other)+import Recognize.Data.Math+import Recognize.Data.MathStoryProblem+import Recognize.Data.MathParserOptions+import Recognize.Data.MathParserOutput+import Recognize.Data.Diagnosis+import Recognize.Data.Step+import Recognize.Data.StringLexer+import Recognize.Expr.Functions+import Recognize.Expr.Normalform+import Recognize.Parsing.Derived+import Recognize.Parsing.Parse+import Recognize.SubExpr.SEParser+import Recognize.Recognizer+import Recognize.SubExpr.Recognizer+import Recognize.SubExpr.Symbols+import Task.VPattern.Assess+import Domain.Math.Data.Relation+import Domain.Math.Expr.Data+import Ideas.Common.Id+import Task.Network.VPattern+import Bayes.Evidence ( evidenceOfAbsence )++vPattern :: MathStoryProblem+vPattern = mathStoryProblem+   { problemId   = newId "vpattern"+   , analyzers   = [(newId "10", ana)]+   , inputFile   = Just "input/vpattern.csv"+   , networkFile = Just "networks/VPattern.xdsl"+   , singleNetwork = network+   }+ where+   ana = analyzer+      { parser     = mathParser mathParserOptions { functionCallWhitelist = "nN" } . stringLexerOutput+      , recognizer = seRecognizer pDiagnosis . mathParserOutput+      , collector  = evidenceOfAbsence ans1 False . assess'+      }++pDiagnosis :: SEParser Diagnosis+pDiagnosis = do+  (appr, e, st) <- pSteps+  let sd = newDiagnosis appr st+      -- exprs = rights (map (getResult . getMath) st)+      -- exprAsString = concatMap show exprs+  return $ sd { result = Just e }++pSteps :: SEParser (Approach, Expr, [Step])+pSteps = do+  (app,e,st) <- choice'+    [+      (\(e,st) -> (Algebraic,e,st)) <$> withGuard (not . null . snd) pStepsA1+    , (\(e,st) -> (Other "Algebraic2",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA2+    , (\(e,st) -> (Other "Algebraic3",e,st)) <$> withGuard (not . null . snd) pStepsA3+    , (\(e,st) -> (Other "Algebraic4",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA4+    ]+  _ <- many skip+  return (app,e,st)++{-+1 R+N = 1 + 2R+-}+stepS :: SEParser (Expr, [Step])+stepS = do+  (e,st) <- pMatchSubSteps sexpr+  return (e, appLast (addAttribute (FinalAnswer e)) st)+  where+    sexpr = lbl "S" $ lt "n" newMagicVar $ \x -> noSim $ 1 + 2 * x <!> 2 * x - 1 <!> newMagicNat * x <!> x + x + x++pStepsS :: SEParser (Expr, [Step])+pStepsS = (\(x, y, _) -> (x, y)) <$> pInOrder [const stepS]++{-+R (R+1)+N = R + (R + 1)+N = 2R + 1+-}+pStepsA1 :: SEParser (Expr, [Step])+pStepsA1 = (\(x, y, _) -> (x, y)) <$> pInOrder+  [ const $ pMatchSubSteps aexpr+  , const stepS+  ]+  where+    aexpr = lbl "A1" $ lt "n" newMagicVar $ \x -> noSim $ x + x + 1 <!> x + x - 1++{-+R (R+1)+N = R + (R + 1)+N = 2R + 1+-}+pStepsA2 :: SEParser (Expr, [Step])+pStepsA2 = (\(x, y, _) -> (x, y)) <$> pInOrder+  [ const $ pMatchSubSteps aexpr+  , const stepS+  ]+  where+    aexpr = lbl "A2" $ lt "n" newMagicVar $ \x -> noSim $ x + (x + 1) <!> x + (x - 1)++{-+2 3++R = 1 N = 2+R = 2 N = 3+N = 3 + 2*(R-1)+N = 3 + 2*R - 2+N = 1 + 2*R+-}+pStepsA3 :: SEParser (Expr, [Step])+pStepsA3 = (\(x, y, _) -> (x, y)) <$> pInOrder+  [ const $ pMatchSubSteps a1expr+  , const $ pMatchSubSteps a2expr+  , const stepS+  ]+  where+    a1expr = lbl "A3_1" $ lt "n" newMagicVar $ \x -> noSim $ 2*(x - 1 <!> x)+    a2expr = lbl "A3_2" $ lt "n" newMagicVar $ \x -> noSim $ 3 + 2*(x - 1 <!> x) <!> 2 + 3*(x-1 <!> x)++pStepsA4 :: SEParser (Expr, [Step])+pStepsA4 = (\(x, y, _) -> (x, y)) <$> pInOrder+  [ const $ second (maybe [] ((:[]) . addAttribute (Label "2")) . mergeSteps) <$> withGuard (\t -> length (snd t) >= 2) (pNumSteps 3)+  , const stepS+  ]++pNumSteps :: Expr -> SEParser (Expr, [Step])+pNumSteps e =+  choice'+    [ do+      (e',ss) <- pNumStep e+      pLog ("successfully parsed a num and value: " ++ show e' ++ " " ++ show ss)+      second (ss:) <$> pNumSteps e'+    , return (e,[])+    ]+    where+      pNumStep ex = do+        (_,b,math) <- choice'+          [ do+            meq <- skip+            (r :==: a) <- getEq meq+            meq2 <- skip+            (n :==: b) <- getEq meq2+            guard (isNat a && isNat b)++            choice'+              [ do+                guard ((n == Var "N" || n == Var "n") && (r == Var "R" || r == Var "r"))+                return (a,b,meq2)+              , do+                guard ((r == Var "N" || r == Var "n") && (n == Var "R" || n == Var "r"))+                return (b,a,meq)+              ]+          , do+            meq <- skip+            (n :==: b) <- getEq meq+            guard (n == Var "N" || n == Var "n")+            return (n,b,meq)+          ]+        (b',attr) <- isVal ex b+        return (b', Step (newId "") (math,attr) [])++isVal :: Expr -> Expr -> SEParser (Expr, [Attribute])+isVal e1 e2 =+  maybeToParse $ msum+    [ do+      guard $ isNat $ nf $ (e2-e1)/2+      return (e2,[])+    , do+      guard $ isNat $ nf $ (e2-e1)/3+      return (e2,[CommonMistake])+    , do+      guard $ isNat $ nf $ (e2-e1)/1+      return (e2,[CommonMistake])+    ]
+ src/Util/Cache.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Util.Cache 
+   ( cached, cached2, cached3, cached4
+   , printCache, writeCache
+   ) where
+
+import Control.Monad
+import qualified Data.Map as M
+import Data.IORef
+import System.IO.Unsafe
+
+cached :: (Ord a, Show a, Show b) => String -> (a -> b) -> a -> b
+cached n = withCache . newCache n
+
+cached2 :: (Ord a, Ord b, Show a, Show b, Show c) => String -> (a -> b -> c) -> a -> b -> c
+cached2 s f = curry $ cached s $ uncurry $ f
+
+cached3 :: (Ord a, Ord b, Ord c, Show a, Show b, Show c, Show d) => String -> (a -> b -> c -> d) -> a -> b -> c -> d
+cached3 s f = curry3 $ cached s $ uncurry3 $ f
+ where
+   curry3 f a b c = f (a, b, c)
+   uncurry3 f (a, b, c) = f a b c 
+
+cached4 :: (Ord a, Ord b, Ord c, Ord d, Show a, Show b, Show c, Show d, Show e) => String -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e
+cached4 s f = curry4 $ cached s $ uncurry4 $ f
+ where
+   curry4 f a b c d = f (a, b, c, d)
+   uncurry4 f (a, b, c, d) = f a b c d
+
+data Cache a b = Cache 
+   { name      :: String
+   , function  :: a -> b
+   , showKey   :: a -> String
+   , showValue :: b -> String
+   , counter   :: IORef Int
+   , cache     :: IORef (M.Map a b)
+   }
+
+newCache :: (Show a, Show b) => String -> (a -> b) -> Cache a b
+newCache n f = unsafePerformIO $ do 
+   r   <- newIORef M.empty
+   cnt <- newIORef 0
+   let c = Cache n f show show cnt r
+   modifyIORef register (c:)
+   return c
+
+withCache :: Ord a => Cache a b -> a -> b
+withCache c a = unsafePerformIO $ do
+   modifyIORef (counter c) (+1)
+   m <- readIORef (cache c)
+   case M.lookup a m of
+      Just b  -> return b
+      Nothing -> do
+         let b = function c a
+         writeIORef (cache c) (M.insert a b m)
+         return b
+         
+------------------------------------------------------------------------
+
+register :: IORef [Cache a b]
+register = unsafePerformIO (newIORef [])
+
+printCache :: IO () 
+printCache = showCache >>= putStrLn
+  
+writeCache :: FilePath -> IO () 
+writeCache file = showCache >>= writeFile file
+
+showCache :: IO String
+showCache = do
+   xs <- readIORef register 
+   fmap unlines $ forM xs $ \c -> do 
+      n <- readIORef (counter c)
+      m <- readIORef (cache c)
+      let sz   = M.size m
+          line = replicate 50 '-'
+          f (a, b) = showKey c a ++ ": " ++ showValue c b
+          summary = name c ++ ": size=" ++ show sz ++ 
+                    ", access=" ++ show n ++ 
+                    ", efficiency=" ++ showRatio (n-sz) n
+      
+      return $ unlines $ summary : line : map f (M.toList m)
+
+showRatio :: Int -> Int -> String
+showRatio a b = show rd
+ where
+   r  = (fromIntegral a / fromIntegral b) :: Double
+   rn = round (r*1000) :: Int
+   rd = (fromIntegral rn/1000) :: Double
+   
+{-
+--  example:
+fib :: Int -> Int
+fib = cached "fib" $ \n -> 
+   if n == 0 then 0
+   else if n == 1 then 1 
+   else fib (n-1) + fib (n-2)
+
+main :: IO ()
+main = do
+   print (fib 50)
+   printCache
+-}
+ src/Util/Expr.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.Expr+   ( substitute, eqComAssoc, isLiteral, isSubExprOf+   , wildcard, wildcardsToVars, restoreWildcards+   ) where++import Control.Applicative+import Control.Monad.State+import Data.Bool+import Domain.Math.Expr+import Ideas.Common.Rewriting.Term+import Ideas.Common.View+import Ideas.Utils.Uniplate+import Util.Monad+import qualified Data.Map as M++substitute :: M.Map String Expr -> Expr -> Expr+substitute m = rec+ where+   rec (Var s) = +      case M.lookup s m of+         -- no occurs check, infinite loop for recursive definitions, but bounded by time constraint. +         -- todo: implement occurs check.+         Just e | s `notElem` vars e -> rec e+         _ -> Var s+   rec e = descend rec e++wildcardSymbol :: Symbol+wildcardSymbol = newSymbol "wildcard"++isWildcardSymbol :: Symbol -> Bool+isWildcardSymbol = (== wildcardSymbol)++-- a wildcard matches any expression.+-- we can use multiple wildcards in a single expression, we can+-- distinguish between wildcards using identifiers (as variables)+wildcard :: String -> Expr+wildcard s = Sym wildcardSymbol [Var s]++prefixVariables :: Char -> Expr -> Expr+prefixVariables s (Var v) = Var (s : v)+prefixVariables _ a@(Sym s _) | isWildcardSymbol s = a+prefixVariables s e = descend (prefixVariables s) e++instantiateWildcards :: Expr -> Expr+instantiateWildcards (Sym s [Var v]) | isWildcardSymbol s = Var ('w':v)+instantiateWildcards e = descend instantiateWildcards e++wildcardsToVars :: Expr -> Expr+wildcardsToVars = instantiateWildcards . prefixVariables 'v'++restoreWildcards :: Expr -> Expr+restoreWildcards (Var ('v':v)) = Var v+restoreWildcards (Var ('w':v)) = wildcard v+restoreWildcards e = descend restoreWildcards e++isLiteral :: Expr -> Bool+isLiteral (Nat _) = True+isLiteral (Negate n) = isLiteral n+isLiteral (Number _) = True+isLiteral _ = False++eq :: MonadState (M.Map String Expr, M.Map String (Expr -> Bool)) m => Expr -> Expr -> m Bool+eq x y = do+   s <- get+   b <- eq' x y+   unless b (put s)+   return b++eq' :: MonadState (M.Map String Expr, M.Map String (Expr -> Bool)) m => Expr -> Expr -> m Bool+eq' (Sym s1 _) (Sym s2 _) | isWildcardSymbol s1  && isWildcardSymbol s2 = return False+eq' a b@(Sym s _) | isWildcardSymbol s = eq' b a+eq' (Sym s [Var v]) b | isWildcardSymbol s = do (me,pe) <- get+                                                case (M.lookup v me, M.lookup v pe) of+                                                 (Just a, _) -> eq' a b+                                                 (_, Just p) | not (p b) -> return False+                                                 _ -> put (M.insert v b me, pe) >> return True+eq' (Nat a) (Nat b) = return (a == b)+eq' (Number a) (Number b) = return (a == b)+eq' (Var a) (Var b) = return (a == b)+eq' a b | Just (sa,[a1,a2]) <- getFunction a+       , Just (sb,[b1,b2]) <- getFunction b+       , sa == sb+       , sa == plusSymbol || sa == timesSymbol --commutativity+       = do a1b1 <- eq' a1 b1+            a2b1 <- eq' a2 b1+            a1b2 <- eq' a1 b2+            a2b2 <- eq' a2 b2+            return ((a1b1 && a2b2) || (a1b2 && a2b1))+eq' a b | Just (sa,as) <- getFunction a+       , Just (sb,bs) <- getFunction b+       , sa == sb+       = and <$> zipWithM eq' as bs+eq' _ _ = return False++isSubExprOf :: (Expr -> Expr) -> Expr -> Expr -> State (M.Map String Expr, M.Map String (Expr -> Bool)) Bool+isSubExprOf norm se e = state (\s -> maybe (False,s) (first (const True)) (runStateT (extractSum norm e se) s))++eqComAssoc :: (Expr -> Expr) -> Expr -> Expr -> State (M.Map String Expr, M.Map String (Expr -> Bool)) Bool+eqComAssoc norm e se = state (\s -> maybe (False,s) (first null) (runStateT (extractSum norm e se) s))++-- @extractSum e s@ tries to extract each sum part of @s@ from @e@ and returns+-- the list of remaining sum operands of @e@.+extractSum :: (Expr -> Expr) -> Expr -> Expr -> StateT (M.Map String Expr, M.Map String (Expr -> Bool)) Maybe [Expr]+extractSum norm e s =+  mIf (eqOrNorm norm e s) (return []) empty <|>+  foldM+   (extractSumMember norm)+   (from sumView s)+   (from sumView e)+   -- (return $ from sumView s)+{-+  do+ (b,xs) <- tryOrDiscardOn fst $+  foldM+   (extractSumMember norm)+   (True, from sumView s)+   (filter (not.hasWildcard) (from sumView e) ++ filter hasWildcard (from sumView e))+ if (not b)+ then do x <- eqOrNorm norm e s+         return (x,if x then [] else from sumView s)+ else return (b,xs)+-}+-- | @extractSumPart norm sv r@ tries to extract expression @r@ from @sv@.+-- When @r@ is a wildcard, we first try to match the wildcard to the entire sum+-- Note that there is also a possibility for the wildcard to match a subset of the sum but we disregard this.+-- If there is no wildcard or it does not match, we try to see if we can find a part of the sum for which+-- we can extract a product.+extractSumMember :: (Expr -> Expr) -> [Expr] -> Expr -> StateT (M.Map String Expr, M.Map String (Expr -> Bool)) Maybe [Expr]+extractSumMember norm eSumMembers sSumMember  = case sSumMember of+                   Sym s [Var _] | isWildcardSymbol s -> mIf (eq sSumMember (to sumView eSumMembers)) (return []) noWildcardCase+                   _ -> noWildcardCase+  where noWildcardCase = do xs <- deleteByM (\x y -> null <$> extractProduct norm x y) sSumMember eSumMembers+                            guard (length xs < length eSumMembers)+                            return xs+                            -- return (p && length xs < length eSumMembers,xs)+++extractProduct :: (Expr -> Expr) -> Expr -> Expr -> StateT (M.Map String Expr, M.Map String (Expr -> Bool)) Maybe [Expr]+extractProduct norm e s = guard (eEven == sEven) >>+     foldM (extractProductMember norm b) sProductMembers eProductMembers+ <|> mIf (eqOrNorm norm e s) (return []) empty+ {-+ <|> [] <$ eqOrNorm norm e s  -- TODO: only when eqOrNorm is True+ <|> return sProductMembers+  -}+  where+   (eEven, eProductMembers) = from productView e+   (sEven, sProductMembers) = from productView s+   b = True -- length sumX == 1 && length xProducts == 1++extractProductMember :: (Expr -> Expr) -> Bool -> [Expr] -> Expr -> StateT (M.Map String Expr, M.Map String (Expr -> Bool)) Maybe [Expr]+extractProductMember norm _ sv r = do+  xs <- deleteByM (eqOrNorm norm) {-(if b then eqOrNorm norm else eqComAssoc norm) -} r sv+  guard (length xs < length sv)+  return xs++  -- return (p && length xs < length sv,xs)+++eqOrNorm :: MonadState (M.Map String Expr, M.Map String (Expr -> Bool)) m => (Expr -> Expr) -> Expr -> Expr -> m Bool+eqOrNorm norm x y = do b <- eq x y+                       if b then return True+                            else eq (norm x) (norm y)++-- helper+mIf :: Applicative m => m Bool -> m a -> m a -> m a+mIf = (flip . fmap flip) (liftA3 bool)
+ src/Util/List.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.List+   ( safeHead, returnOnJustM, groupings, cartProd+   , selections, safeSingleton, safeLast, appLast, modifyAt+   , index+   , concatMapM+   , groupBy'+   , orderBy+   ) where++import Data.Function (on)+import Data.List (elemIndex, sortBy, groupBy)+import Control.Arrow (second, (&&&))++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x++safeLast :: [a] -> Maybe a+safeLast = foldl (\_ a -> Just a) Nothing++appLast :: (a -> a) -> [a] -> [a]+appLast _ [] = []+appLast f [a] = [f a]+appLast f (x:xs) = x : appLast f xs++modifyAt :: Int -> (a -> a) -> [a] -> [a]+modifyAt _ _ [] = []+modifyAt n f (x:xs)+  | n == 0 = f x : xs+  | otherwise = x : modifyAt (n-1) f xs++safeSingleton :: [a] -> Maybe a+safeSingleton [a] = Just a+safeSingleton _ = Nothing++cartProd :: [a] -> [b] -> [(a,b)]+cartProd xs ys = do+  x <- xs+  y <- ys+  return (x,y)++selections :: [a] -> [(a,[a])]+selections [] = []+selections (x:xs) = (x,xs) : map (second (x:)) (selections xs)++returnOnJustM :: (Monad m, Show a) => (a -> m (Maybe b)) -> [a] -> m (Maybe (b, [a]))+returnOnJustM _ [] = return Nothing+returnOnJustM f input =+  returnAndRetain f [] input+  where+    returnAndRetain _ _ [] = return Nothing+    returnAndRetain f old new@(x:xs) = do+      fx <- f x+      case fx of+        Nothing -> returnAndRetain f (old ++ [x]) xs+        Just b  -> return $ Just (b, old ++ new)++groupings :: [a] -> [b] -> [[(a,b)]]+groupings [] _ = [[]]+groupings _ [] = [[]]+groupings (a:as) bs = concatMap (\(x,xs) -> map ((a,x):) $ groupings as xs) $ selections bs++-- | Find index of an element in a list.+index :: Eq a => [a] -> a -> Maybe Int+index list = flip elemIndex list++-- | Monadic 'concatMap'.+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = concat <$> mapM f xs++-- | Alternative to 'Data.List.groupBy', where only adjacent elements are+-- compared - so the predicate does not assume transitivity.+groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy' _ [] = []+groupBy' _ [x] = [[x]]+groupBy' predicate (x:y:xs)+   | predicate x y = let sameGroup:diffGroups = groupBy' predicate (y:xs)+                in  (x:sameGroup):diffGroups+   | otherwise = [x] : groupBy' predicate (y:xs)++++-- | Alternative to 'Data.List.groupBy', in which the list is sorted and grouped+-- on a certain attribute, and each group is labelled with said attribute.+orderBy :: (Ord b) => (a->b) -> [a] -> [(b,[a])]+orderBy attribute+   = map (fst . head &&& map snd)+   . groupBy ((==) `on` fst) +   . sortBy (compare `on` fst)+   . map (attribute &&& id)
+ src/Util/Monad.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.Monad+   ( deleteByM, anyM, allM, applyFirstM, withGuard, mWhen+   ) where++import Control.Applicative+import Control.Monad++applyFirstM :: Monad m => (a -> m a) -> m (a, b) -> m (a,b)+applyFirstM f sp = sp >>= \(e,b) -> f e >>= \e' -> return (e',b)++allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM p xs = do+  bs <- mapM p xs+  return $ and bs++anyM :: (Show a, Monad m) => (a -> m Bool) -> [a] -> m Bool+anyM _ [] = return False+anyM p (x:xs) = do+  b <- p x+  if b then return True+       else anyM p xs++deleteByM                :: Monad m => (a -> a -> m Bool) -> a -> [a] -> m [a]+deleteByM _  _ []        = return []+deleteByM eq x (y:ys)    = do b <- x `eq` y+                              if b then return ys+                                   else (y :) <$> deleteByM eq x ys++withGuard :: (Monad m, Alternative m) => (a -> Bool) -> m a -> m a+withGuard p m = do+  a <- m+  guard (p a)+  return a+++mWhen :: Monoid m => Bool -> m -> m+mWhen True m = m+mWhen False _ = mempty
+ src/Util/NumberRange.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Data type for ranges of numbers.+--+-----------------------------------------------------------------------------++module Util.NumberRange (NumberRange, range) where++import Control.Monad (forM)+import Data.Semigroup+import Util.String (split)+import Util.List (groupBy')+import Data.List (sort, nub, intercalate)+import Database.HDBC (SqlValue, fromSql, toSql)+import Data.Convertible.Base (Convertible, safeConvert, convError)+import Ideas.Utils.Prelude (readM)++newtype NumberRange = NumberRange [Int]++range :: [Int] -> NumberRange+range = NumberRange . nub++instance Semigroup NumberRange where+   (NumberRange r1) <> (NumberRange r2) = NumberRange . nub $ r1 ++ r2++instance Monoid NumberRange where+   mempty  = NumberRange []+   mappend = (<>)++instance Show NumberRange where+   show (NumberRange range) +      = intercalate "," +      . map f +      . groupBy' (\x y -> abs (x - y) == 1) +      . sort+      $ range+  +      where +      f [] = show ""+      f [x] = show x+      f xs = show (head xs) ++ "-" ++ show (last xs)++instance Convertible NumberRange SqlValue where+   safeConvert = Right . toSql . show++instance Convertible SqlValue NumberRange where+   safeConvert sql = either (flip convError sql) Right $ do+      let string = fromSql sql+      ranges <- forM (split ',' string) $ \range ->+         case split '-' range of+            [i] -> do+               i' <- readM i+               return [i']+            [i,j] -> do+               i' <- readM i+               j' <- readM j+               return [i'..j']+            _ -> fail "number range could not be parsed"+      return . NumberRange . concat $ ranges+
+ src/Util/Parentheses.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.Parentheses where++balanced :: String -> Bool+balanced = rec ""+ where+  rec st [] = null st+  rec st (x:xs)+      | x `elem` "([{" = rec (x:st) xs+      | x `elem` ")]}" = match (take 1 st) x && rec (drop 1 st) xs+      | otherwise      = rec st xs++  match :: String -> Char -> Bool+  match "(" ')' = True+  match "[" ']' = True+  match "{" '}' = True+  match _   _   = False
+ src/Util/Pretty.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- Prettyprinting for commonly used datatypes.+--+-----------------------------------------------------------------------------++module Util.Pretty where++import Text.PrettyPrint.Leijen ( (<$$>) )+import qualified Data.Map as M+import qualified Text.PrettyPrint.Leijen as PP++prettyMap :: (PP.Pretty a, PP.Pretty b) => M.Map a b -> PP.Doc+prettyMap = (<$$> PP.empty)+          . PP.vsep+          . map (\(k,v) -> PP.empty <$$> PP.pretty k <$$> PP.indent 4 (PP.pretty v))+          . M.toList+
+ src/Util/String.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.String where++import Data.Char+import Data.List+import Text.Printf ( printf, PrintfType )++-- | Trim whitespace from the beginning and end of a string.+trim :: String -> String+trim = dropWhileEnd isSpace . dropWhile isSpace++-- | Split on elements of a list.+split :: Eq a => a -> [a] -> [[a]]+split _ [] = []+split delimiter string = +   let (a,b) = span (/= delimiter) string+   in  a:split delimiter (drop 1 b)++-- | Add characters before, between and after a string.+wrap :: String -> String -> String -> [String] -> String+wrap before between after elems =+   before ++ intercalate between elems ++ after++strToLower :: String -> String+strToLower = map toLower++strToUpper :: String -> String+strToUpper = map toUpper++splitOn :: Eq a => [a] -> [a] -> ([a],[a])+splitOn = flip splitOn' []++splitOn' :: Eq a => [a] -> [a] -> [a] -> ([a],[a])+splitOn' [] zs _ = (reverse zs, [])+splitOn' yss@(y:ys) zs xs | xs `isPrefixOf` yss = (reverse zs, drop (length xs) yss)+                          | otherwise = splitOn' ys (y:zs) xs++breaksOn :: (a -> Bool) -> [a] -> [[a]]+breaksOn _ [] = []+breaksOn p xs | (a,ys) <- break p xs = a : breaksOn p (case ys of+                                                        [] -> []+                                                        _:zs -> zs)++indent :: String -> String+indent = unlines . map ('\t':) . lines++replace :: String -> String -> String -> String+replace _ _ [] = []+replace x y oz@(z:zs) | Just r <- stripPrefix x oz = y ++ replace x y r+                      | otherwise = z : replace x y zs++-- | Make string lowercase and remove non-alphanumerics.+normalize :: String -> String+normalize xs = [ toLower x | x <- xs, isAlphaNum x ]+++-- | Format a double n to a percentage with i decimals.+percentage :: Int -> Double -> String+percentage i = printf ("%." ++ show i ++ "f%%") . (* 100)+++-- | Generic division.+(//) :: (Real a, Real b) => a -> b -> Double+a // b = realToFrac a / realToFrac b
+ src/Util/Table.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Util.Table
+   ( Tables, tables, tableList
+   , Table
+   , Count
+   , count, percentage
+   ) where
+
+import Data.Semigroup
+import qualified Data.Map as M
+
+newtype Count = C Int
+
+instance Show Count where
+   show (C n) = show n
+
+instance Semigroup Count where
+   C x <> C y = C (x + y)
+
+instance Monoid Count where
+   mempty  = C 0
+   mappend = (<>)
+
+data Percentage = P Int Int
+
+instance Show Percentage where
+   show (P x y) = show x ++ " (" ++ showAsPerc (fromIntegral x / fromIntegral y) ++ ")"
+
+count :: String -> String -> Tables Count
+count t s = tables (one' t s)
+
+one' :: String -> String -> Table Count
+one' t s = Table t (TD (M.singleton s (C 1)))
+
+percentage :: Tables Count -> Tables Percentage
+percentage (Tables m) = Tables (M.map perc m)
+
+perc :: TableData Count -> TableData Percentage
+perc (TD m) = TD (M.map g m)
+ where
+   C y = mconcat (M.elems m)
+   g (C x) = P x y
+
+newtype Tables a = Tables (M.Map String (TableData a))
+
+instance Show a => Show (Tables a) where
+   show = unlines . map show . tableList
+
+instance Semigroup a => Semigroup (Tables a) where
+   Tables m1 <> Tables m2 = Tables (M.unionWith (<>) m1 m2)
+
+instance Semigroup a => Monoid (Tables a) where
+   mempty  = Tables mempty
+   mappend = (<>)
+
+tableList :: Tables a -> [Table a]
+tableList (Tables m) = map (uncurry Table) (M.toList m)
+
+tables :: Table a -> Tables a
+tables t = Tables (M.singleton (title t) (tableData t))
+
+data Table a = Table { title :: String, tableData :: TableData a }
+
+instance Show a => Show (Table a) where
+   show t = title t ++ "\n" ++ show (tableData t)
+
+newtype TableData a = TD (M.Map String a)
+
+instance Show a => Show (TableData a) where
+   show (TD m) = unlines (line : zipWith colon (map (ljustify lx) xs) ys)
+    where
+      colon x y = x ++ " : " ++ y
+      line = replicate (lx + ly + 3) '-'
+      xs = M.keys m
+      ys = map show (M.elems m)
+      lx = maximum (0 : map length xs)
+      ly = maximum (0 : map length ys)
+
+instance Semigroup a => Semigroup (TableData a) where
+   TD m1 <> TD m2 = TD (M.unionWith (<>) m1 m2)
+
+instance Semigroup a => Monoid (TableData a) where
+   mempty  = TD mempty
+   mappend = (<>)
+
+ljustify :: Int -> String -> String
+ljustify n s = take n (s ++ repeat ' ' )
+
+showAsPerc :: Rational -> String
+showAsPerc r = show d ++ "." ++ show m ++ "%"
+ where
+   n = round (r * 1000) :: Int
+   (d, m) = n `divMod` 10
+ src/Util/TableData.hs view
@@ -0,0 +1,172 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-- This module produces tabular data in HTML or CSV format.+--+-----------------------------------------------------------------------------++-- Makes things hard to read, please eliminate it if you have the chance.+module Util.TableData +   ( Table(Table)+   , fromList+   , toTable+   , toTableFromRows+   , toTableFromCols+   , empty+   , get+   , colHeaders+   , rowHeaders+   , addRow+   , addCol+   , addCell+   , htmlTable+   , csvTable ) where++import Data.List (foldl', nub, intercalate)+import qualified Data.Map as M++import Ideas.Text.XML (tag, string)+import Ideas.Text.HTML (HTMLBuilder)+import qualified Ideas.Text.HTML.W3CSS as W3+++-- | A 'Table' is simply a 'M.Map' representing a tabular structure.+newtype Table row col cell = Table +   { mapping :: M.Map (row, col) cell }+++-- | Create a 'Table' from a list.+fromList :: (Ord row, Ord col) +         => [((row, col), cell)] +         -> Table row col cell+fromList = Table . M.fromList+++-- | Obtain an empty 'Table'.+empty :: Table row col cell+empty = Table M.empty+++-- | Get a list of all row headers.+rowHeaders :: (Eq row) => Table row col cell -> [row]+rowHeaders = nub . map fst . M.keys . mapping+++-- | Get a list of all column headers.+colHeaders :: (Eq col) => Table row col cell -> [col]+colHeaders = nub . map snd . M.keys . mapping+++-- | Turn a foldable collection of data into a tabular structure.+toTable :: (Foldable t, Ord row, Ord col) +        => (a -> row) +        -> (a -> col) +        -> (a -> cell) +        -> t a +        -> Table row col cell+toTable extractRow extractCol extractCell = +   let f xs x = addCell (extractCell x) (extractRow x) (extractCol x) xs+   in foldl' f empty+++-- | Turn a foldable collection of data into a tabular structure, where every+-- element of the collection contains multiple columns.+toTableFromRows :: (Foldable t, Foldable t', Ord row, Ord col) +                => (a -> row) +                -> (a -> t' (col, cell)) +                -> t a +                -> Table row col cell+toTableFromRows extractRow extractCols = +   let f xs x = addRow (extractRow x) (extractCols x) xs+   in foldl' f empty+++-- | Turn a foldable collection of data into a tabular structure, where every+-- element of the collection contains multiple rows.+toTableFromCols :: (Foldable t, Foldable t', Ord row, Ord col) +                => (a -> col) +                -> (a -> t' (row, cell)) +                -> t a +                -> Table row col cell+toTableFromCols extractCol extractRows = +   let f xs x = addCol (extractCol x) (extractRows x) xs+   in foldl' f empty++++-- | Add a row to a 'Table'.+addRow :: (Foldable t, Ord row, Ord col) +       => row +       -> t (col, cell) +       -> Table row col cell +       -> Table row col cell+addRow row = flip $ foldl' (\t (col, cell) -> addCell cell row col t)+++-- | Add a column to a 'Table'.+addCol :: (Foldable t, Ord row, Ord col) +       => col +       -> t (row, cell) +       -> Table row col cell +       -> Table row col cell+addCol col = flip $ foldl' (\t (row, cell) -> addCell cell row col t)+++-- | Add a cell to a 'Table'.+addCell :: (Ord row, Ord col) +        => cell -> row -> col +        -> Table row col cell +        -> Table row col cell+addCell cell row col = Table . M.insert (row, col) cell . mapping+++-- | Obtain the cell at (row, col).+get :: (Ord row, Ord col) => row -> col -> Table row col cell -> Maybe cell+get row col = M.lookup (row,col) . mapping+++-- | Format a 'Table' as HTML.+htmlTable :: (Ord row, Ord col)+          => (row -> HTMLBuilder)+          -> (col -> HTMLBuilder)+          -> (cell -> HTMLBuilder)+          -> Table row col cell +          -> HTMLBuilder+htmlTable buildRow buildCol buildCell table' = W3.tableAll . mconcat $+      ( tag "th" . mconcat . map (tag "td" . buildCol) $ colHeaders table' )+      :+      [ tag "tr" . mconcat $+         tag "td" (buildRow row')+         :+         [ tag "td" (maybe (W3.textColor W3.Gray $ string "x") buildCell $ get row' col' table')+         | col' <- colHeaders table'+         ] +      | row' <- rowHeaders table'+      ]+++-- | Format a 'Table' as CSV.+csvTable :: (Ord row, Ord col) +         => (row -> String)+         -> (col -> String)+         -> (cell -> String)+         -> Table row col cell +         -> String+csvTable buildRow buildCol buildCell table' = intercalate "\r\n" . map (intercalate ",") $+      ( "" : map buildCol (colHeaders table'))+      :+      [  buildRow row'+         :+         [ maybe "" buildCell $ get row' col' table'+         | col' <- colHeaders table'+         ] +      | row' <- rowHeaders table'+      ]+
+ src/Util/W3CSSHTML.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Advise-Me project team. This file is distributed under +-- the terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer  :  bastiaan.heeren@ou.nl+-- Stability   :  provisional+-- Portability :  portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Util.W3CSSHTML+   ( w3table, w3list, w3tags, th, td, tr, makePage, writePage+   ) where++import Data.Monoid ( (<>) )+import Ideas.Text.HTML hiding (table)+import Ideas.Text.HTML.W3CSS+import Ideas.Text.XML hiding (tag)+import qualified Ideas.Text.XML as XML (tag)+import System.Directory++w3table :: BuildXML a => Bool -> [[a]] -> a+w3table b xss+   | null xss  = mempty+   | otherwise = XML.tag "table " . table . border . bordered+               . mconcat . zipWith row [0 :: Int ..] $ xss+ where+   row i =+      let header = b && i == 0+      in element "tr" . map (if header then XML.tag "th" else XML.tag "td")++w3list :: BuildXML a => [a] -> a+w3list = w3table False . map return++w3tags :: [(String, Color)] -> HTMLBuilder+w3tags xs+   | null xs   = mempty+   | otherwise = spaced $ map f xs+ where+   f (s, c) = tag . background c . rounded Medium . marginPos Bottom . string $ s++tr :: [HTMLBuilder] -> HTMLBuilder+tr xs = if null xs then mempty else element "tr" xs++td :: HTMLBuilder -> HTMLBuilder+td = XML.tag "td"++th :: HTMLBuilder -> HTMLBuilder+th = XML.tag "th"++writePage :: String -> HTMLPage -> IO ()+writePage s p = do+   let file = "html/" ++ s ++ ".html"+   putStrLn $ "Generating " ++ file+   createDirectoryIfMissing True "html"+   writeFile file (showHTML p)++{-addCSS "https://www.w3schools.com/lib/w3-theme-blue-grey.css" -}+makePage :: String -> HTMLBuilder -> HTMLPage+makePage title contents =+ ( addStyle "body { background-color: #9b2335 }"+ . w3css+ . addCSS "http://ideas.cs.uu.nl/css/2007-chili-pepper.css"+ . htmlPage title+ . divClass "body"+ . w3class "w3-theme-d2"+ . container+ ) (h1 title <> contents)
+ src/Util/XML.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------
+-- Copyright 2019, Advise-Me project team. This file is distributed under 
+-- the terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Util.XML where
+
+import Data.List
+import Domain.Math.Expr.Data
+import Ideas.Common.Rewriting
+import Data.Maybe
+import Ideas.Encoding.OpenMathSupport
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.XML
+import Ideas.Text.HTML (ToHTML(..))
+
+unescape :: String -> String
+unescape [] = []
+unescape xs@(y:ys) | "&lt;" `isPrefixOf` xs   = '<' : unescape (drop 4 xs)
+                   | "&gt;" `isPrefixOf` xs   = '>' : unescape (drop 4 xs)
+                   | "&amp;" `isPrefixOf` xs  = '&' : unescape (drop 5 xs)
+                   | "&quot;" `isPrefixOf` xs = '\"' : unescape (drop 6 xs)
+                   | "&apos;" `isPrefixOf` xs = '\'' : unescape (drop 6 xs)
+                   | "&#10;" `isPrefixOf` xs  = '\n' : unescape (drop 5 xs)
+                   | otherwise                = y : unescape ys
+
+unescapeAttr :: String -> String
+unescapeAttr [] = []
+unescapeAttr xs@(y:ys)
+              | "&lt;" `isPrefixOf` xs   = '<' : unescapeAttr (drop 4 xs)
+              | "&amp;" `isPrefixOf` xs   = '&' : unescapeAttr (drop 5 xs)
+              | "&quot;" `isPrefixOf` xs   = '\"' : unescapeAttr (drop 6 xs)
+              | otherwise                = y : unescape ys
+
+instance (ToXML a, ToXML b) => ToXML (Either a b) where
+  toXML (Left x)  = makeXML "either_left"  $ builderXML x
+  toXML (Right x) = makeXML "either_right" $ builderXML x
+
+instance (InXML a, InXML b) => InXML (Either a b) where
+  fromXML xml =
+     case children xml of
+        [a] | name xml == "either_left"  -> Left  <$> fromXML a
+            | name xml == "either_right" -> Right <$> fromXML a
+        _ -> fail "invalid xml for Either type"
+
+instance ToXML Expr where
+   toXML ex = toXML (toOMOBJ (fromJust (fromExpr ex) :: Term))
+
+instance ToHTML Expr where
+ toHTML = mempty
+
+instance InXML Expr where
+ fromXML ex = case xml2omobj ex of
+                 Left e -> fail ("Util.XML:InXML.Expr : " ++ e)
+                 Right r -> pure (let x :: Term
+                                      x = fromJust (fromOMOBJ r)
+                                  in toExpr x)