diff --git a/CHANGELOG b/CHANGELOG
new file mode 100644
--- /dev/null
+++ b/CHANGELOG
@@ -0,0 +1,5 @@
+HsQML Manic - Release History
+
+release-0.3.4.0 - 2016.10.16
+
+ * Initial release.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2014-2016, Robin KAY
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Robin KAY nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/hsqml-demo-manic.cabal b/hsqml-demo-manic.cabal
new file mode 100644
--- /dev/null
+++ b/hsqml-demo-manic.cabal
@@ -0,0 +1,37 @@
+Name: hsqml-demo-manic
+Version: 0.3.4.0
+Cabal-version: >=1.10
+Build-type: Simple
+License: BSD3
+License-file: LICENSE
+Copyright: (c) 2014-2016 Robin KAY
+Author: Robin KAY
+Maintainer: komadori@gekkou.co.uk
+Homepage: http://www.gekkou.co.uk/software/hsqml/
+Category: Game
+Synopsis: HsQML-based clone of Pipe Mania
+Data-dir: qml
+Data-files: *.qml *.svg
+Extra-source-files: CHANGELOG
+Description:
+ HsQML-based clone of Pipe Mania
+
+executable hsqml-manic
+ Default-language: Haskell2010
+ Hs-source-dirs: src
+ Main-is: Main.hs
+ Other-extensions:
+ ScopedTypeVariables,
+ DeriveDataTypeable,
+ TypeFamilies
+ Build-depends:
+ base == 4.*,
+ containers >= 0.4 && < 0.6,
+ text >= 0.11 && < 1.3,
+ MonadRandom >= 0.4 && < 0.5,
+ hsqml >= 0.3.4 && < 0.4
+ GHC-options: -threaded
+
+Source-repository head
+ type: darcs
+ location: http://hub.darcs.net/komadori/hsqml-demo-manic
diff --git a/qml/BasicTileTest.qml b/qml/BasicTileTest.qml
new file mode 100644
--- /dev/null
+++ b/qml/BasicTileTest.qml
@@ -0,0 +1,38 @@
+import QtQuick 2.0
+
+Grid {
+ columns: 5;
+ columnSpacing: 5;
+ rowSpacing: 5;
+
+ property var colours: ['lime','yellow','darkgoldenrod','blue'];
+ property int colIndex: 0;
+
+ property double vol: 0;
+ SequentialAnimation on vol {
+ NumberAnimation {
+ from: 0; to: 0; duration: 1000;
+ }
+ NumberAnimation {
+ from: 0; to: 1.1; duration: 5000;
+ }
+ NumberAnimation {
+ from: 1.1; to: 1.1; duration: 1000;
+ }
+ ScriptAction {
+ script: colIndex = (colIndex+1)%colours.length;
+ }
+ loops: Animation.Infinite;
+ }
+
+ Repeater {
+ model: 25;
+
+ Plumb {
+ entryA: Math.floor(index / 5) * 90;
+ exitA: (index % 5) * 90;
+ colour: colours[colIndex];
+ volume: vol;
+ }
+ }
+}
diff --git a/qml/Board.qml b/qml/Board.qml
new file mode 100644
--- /dev/null
+++ b/qml/Board.qml
@@ -0,0 +1,222 @@
+import QtQuick 2.0
+import QtGraphicalEffects 1.0
+import HsQML.Model 1.0
+
+Item {
+ id: c;
+ property int tilesWide : 8;
+ property int tilesHigh : 8;
+ property bool isVirtual : false;
+ property color bgColor : 'cornsilk';
+
+ property double tileSize : Math.floor(Math.min(
+ width / tilesWide, height / tilesHigh));
+ property var tileSource : newTileSource();
+ property var gridModel : newGrid();
+ property var plumbedGrid : gridModel.plumb();
+
+ signal pressedComplete();
+
+ property double countDown;
+ NumberAnimation on countDown {
+ id: countAnim;
+ from: 3; to: 0;
+ duration: 9000;
+ running: false;
+ onStopped: volumeAnim.start();
+ }
+
+ property double n : 0;
+ NumberAnimation on n {
+ id: volumeAnim;
+ from: 0; to: 100 + 0.1;
+ duration: 5000 * (100 + 0.1);
+ running: false;
+ }
+
+ property bool gameOver :
+ (!countAnim.running && !volumeAnim.running) ||
+ n > (plumbedGrid.maxIndex+1) ||
+ plumbedGrid.leaks.length == 0;
+
+ function start() {
+ tileSource = newTileSource();
+ gridModel = newGrid();
+ if (c.isVirtual) {
+ virtualMouse.pick();
+ }
+ countAnim.restart();
+ volumeAnim.stop();
+ n = 0;
+ }
+
+ Rectangle {
+ width: c.tileSize*c.tilesWide;
+ height: c.tileSize*c.tilesHigh;
+ color: c.bgColor;
+ MouseArea {
+ id: realMouse;
+ anchors.fill: parent;
+ hoverEnabled: true;
+ }
+ }
+
+ Repeater {
+ anchors.fill: parent;
+ model: AutoListModel {
+ mode: AutoListModel.ByKey;
+ source: {
+ var rs = plumbedGrid.leaks;
+ rs.sort(function(a,b) {return a.idx-b.idx;});
+ return rs;
+ }
+ equalityTest: function(a,b) {
+ a.idx==b.idx && a.colour==b.colour && a.exitA==b.exitA;}
+ keyFunction: function(a) {return a.x+'-'+a.y;}
+ }
+
+ Leak {
+ tileSize: c.tileSize;
+ tileX: modelData.x;
+ tileY: modelData.y;
+ colour: modelData.colour;
+ exitBearing: modelData.exitA;
+ trigger: n >= modelData.idx;
+ }
+ }
+
+ Repeater {
+ id: tiles;
+ model: AutoListModel {
+ source: plumbedGrid.plumbing;
+ mode: AutoListModel.ByKey;
+ equalityTest: function(a,b) {
+ return a.idx==b.idx && a.entryA==b.entryA && a.exitA==b.exitA;}
+ keyFunction: function(a) {return a.x+"-"+a.y;}
+ }
+
+ Plumb {
+ tileSize: c.tileSize;
+ x: modelData.x*c.tileSize;
+ y: modelData.y*c.tileSize;
+ entryA: modelData.entryA;
+ exitA: modelData.exitA;
+ colour: modelData.colour;
+ label: modelData.colour;
+ volume: modelData.idx < 0 ?
+ 0 : Math.min(Math.max(c.n-modelData.idx,0),1.1);
+ }
+ }
+
+ Text {
+ visible: c.countDown > 0;
+ anchors.centerIn: parent;
+ text: Math.floor(c.countDown+1);
+ font.pixelSize: c.tileSize*2;
+ scale: 1+Math.ceil(c.countDown)-c.countDown;
+ opacity: 0.5-(Math.ceil(c.countDown)-c.countDown)/2;
+ }
+
+ Rectangle {
+ id: mouseView;
+ property var mouse: c.gameOver ? noMouse :
+ (c.isVirtual ? virtualMouse : realMouse);
+ property int tileX: Math.floor(mouse.mouseX/c.tileSize);
+ property int tileY: Math.floor(mouse.mouseY/c.tileSize);
+ property bool tilePlacable:
+ plumbedGrid.isPlacable(Math.floor(c.n), tileX, tileY);
+
+ Connections {
+ target: mouseView.mouse;
+ onPressed: {
+ if (mouseView.tilePlacable) {
+ c.gridModel = c.gridModel.place(
+ mouseView.tileX, mouseView.tileY, tileSource.top.tile);
+ c.tileSource = c.tileSource.next;
+ }
+ c.pressedComplete();
+ }
+ }
+
+ visible: mouseView.mouse.containsMouse;
+ x: tileX*c.tileSize;
+ y: tileY*c.tileSize;
+ width: c.tileSize; height: c.tileSize;
+ color: 'lightgray'; opacity: 0.5;
+ Text {
+ visible: !mouseView.tilePlacable;
+ anchors.centerIn: parent;
+ color: 'red';
+ font.pixelSize: c.tileSize;
+ text: 'X';
+ }
+ }
+
+ Item {
+ id: virtualMouse;
+ property bool done : false;
+ property bool active : true;
+ property double oldTileX : 0;
+ property double oldTileY : 0;
+ property double tileX : 0;
+ property double tileY : 0;
+ property double dur : 0;
+ Behavior on tileX {
+ NumberAnimation {
+ id: animX;
+ duration: virtualMouse.dur;
+ }
+ }
+ Behavior on tileY {
+ NumberAnimation {
+ id: animY;
+ duration: virtualMouse.dur;
+ }
+ }
+ NumberAnimation {
+ id: xyAnim;
+ duration: virtualMouse.dur;
+ onStopped: virtualMouse.pressed();
+ }
+ function pick() {
+ if (done) return;
+ gridModel.pick(c.tileSource, tileX, tileY, Math.floor(c.n));
+ }
+ focus: true;
+ Keys.enabled: true;
+ Keys.onSpacePressed: done = true;
+ function move(pos) {
+ dur = 300*Math.max(1,Math.sqrt(
+ (tileX-pos.x)*(tileX-pos.x)+(tileY-pos.y)*(tileY-pos.y)));
+ tileX = pos.x;
+ tileY = pos.y;
+ xyAnim.start();
+ }
+ Connections {
+ target: c;
+ onPressedComplete: virtualMouse.pick();
+ }
+ Connections {
+ target: c.gridModel;
+ onPicked: virtualMouse.move(pos);
+ }
+ property int mouseX : (tileX+0.5)*c.tileSize;
+ property int mouseY : (tileY+0.5)*c.tileSize;
+ property bool containsMouse : true;
+ signal pressed();
+
+ Image {
+ visible: mouseView.mouse == virtualMouse;
+ x: virtualMouse.mouseX; y: virtualMouse.mouseY;
+ source: 'mouse.svg'
+ }
+ }
+
+ Item {
+ id: noMouse;
+ property int mouseX : 0;
+ property int mouseY : 0;
+ property bool containsMouse : false;
+ signal pressed();
+ }
+}
diff --git a/qml/Leak.qml b/qml/Leak.qml
new file mode 100644
--- /dev/null
+++ b/qml/Leak.qml
@@ -0,0 +1,55 @@
+import QtQuick 2.0
+import QtGraphicalEffects 1.0
+
+Item {
+ id: c;
+ anchors.fill: parent;
+
+ property double tileX : 0;
+ property double tileY : 0;
+ property double tileSize : 100;
+ property int exitBearing : 0;
+ property color colour : 'green';
+ property bool trigger : false;
+
+ onTriggerChanged:
+ if (trigger) {sizeAnim.start();} else {sizeAnim.stop(); grad.size = 0;}
+
+ RadialGradient {
+ id: grad;
+ anchors.fill: parent;
+ property double cx: {
+ var h=0;
+ switch (c.exitBearing) {
+ case 0: h=0.5; break; case 90: h=0.9; break;
+ case 180: h=0.5; break; case 270: h=0.1; break;
+ }
+ return (c.tileX+h)*c.tileSize;
+ }
+ horizontalOffset: cx-c.width/2;
+ property double cy: {
+ var v=0;
+ switch (c.exitBearing) {
+ case 0: v=0.1; break; case 90: v=0.5; break;
+ case 180: v=0.9; break; case 270: v=0.5; break;
+ }
+ return (c.tileY+v)*c.tileSize;
+ }
+ verticalOffset: cy-c.height/2;
+ horizontalRadius: size*1.5*c.tileSize;
+ verticalRadius: size*1.5*tileSize;
+ gradient: Gradient {
+ GradientStop { position: 0.9; color: c.colour; }
+ GradientStop { position: 1.0; color: Qt.rgba(0,0,0,0); }
+ }
+
+ property double size : 0;
+ NumberAnimation on size {
+ id: sizeAnim;
+ from: 0; to: 1;
+ duration: 3000;
+ easing.type: Easing.OutQuad;
+ running: false;
+ }
+ }
+}
diff --git a/qml/Main.qml b/qml/Main.qml
new file mode 100644
--- /dev/null
+++ b/qml/Main.qml
@@ -0,0 +1,133 @@
+import QtQuick 2.0
+import QtQuick.Window 2.0
+import QtQuick.Layouts 1.0
+import HsQML.Model 1.0
+
+Window {
+ visible: true;
+ width: 900; height: 800;
+
+ RowLayout {
+ anchors.fill: parent;
+
+ Item {
+ Layout.fillWidth: true;
+ Layout.fillHeight: true;
+ Board {
+ id: board;
+ anchors.fill: parent;
+ onGameOverChanged: if (board.gameOver) {
+ idleTimer.restart();
+ idleTimer.count = 9;
+ }
+ }
+ Timer {
+ id: idleTimer;
+ interval: 1000;
+ repeat: true;
+ property int count : 10;
+ onTriggered: if (--idleTimer.count == 0) {
+ board.isVirtual = true;
+ board.start();
+ }
+ }
+ Rectangle {
+ width: 1.2*btnText.width;
+ height: 1.2*btnText.height;
+ anchors.centerIn: parent;
+ color: 'green';
+ radius: 0.1*btnText.height;
+ property bool showButton : board.gameOver || board.isVirtual;
+ enabled: showButton;
+ opacity: showButton ? (btnArea.containsMouse ? 1 : 0.5) : 0;
+ Behavior on opacity {
+ NumberAnimation { duration: 500; }
+ }
+ MouseArea {
+ id: btnArea;
+ anchors.fill: parent;
+ hoverEnabled: true;
+ onClicked: {
+ idleTimer.count = 0;
+ board.isVirtual = false;
+ board.start();
+ }
+ cursorShape: Qt.PointingHandCursor;
+ }
+ Text {
+ id: btnText;
+ anchors.centerIn: parent;
+ color: 'white';
+ font.pixelSize: 0.1*board.height;
+ text: 'Play';
+ }
+ }
+ Text {
+ anchors.horizontalCenter: parent.horizontalCenter;
+ anchors.top: top.bottom;
+ anchors.topMargin: 5;
+ visible: board.isVirtual;
+ opacity: 0.5;
+ font.pixelSize: 0.05*board.height;
+ text: 'Demo Mode';
+ }
+ Text {
+ anchors.horizontalCenter: parent.horizontalCenter;
+ anchors.bottom: parent.bottom;
+ anchors.bottomMargin: 5;
+ visible: board.isVirtual;
+ opacity: 0.5;
+ font.pixelSize: 0.05*board.height;
+ text: 'Demo Mode';
+ }
+ Text {
+ anchors.bottom: parent.bottom;
+ anchors.left: parent.left;
+ anchors.bottomMargin: 5;
+ anchors.leftMargin: 5;
+ visible: idleTimer.count > 0;
+ opacity: 0.5;
+ font.pixelSize: 0.05*board.height;
+ text: idleTimer.count;
+ }
+ }
+ ListView {
+ id: tileList;
+ model: AutoListModel {
+ mode: AutoListModel.ByKey;
+ source: board.tileSource.topN(tileList.height/100);
+ equalityTest: function(a, b) {return a.tile == b.tile;}
+ keyFunction: function(x) {return x.idx;}
+ }
+ delegate: Item {
+ width: 100; height: 100;
+ Repeater {
+ anchors.fill: parent;
+ model: sparePart(modelData.tile);
+ Plumb {
+ anchors.fill: parent;
+ entryA: modelData.entryA;
+ exitA: modelData.exitA;
+ volume: 0;
+ }
+ }
+ }
+ displaced: Transition {
+ NumberAnimation { properties: "x,y"; duration: 1000; }
+ NumberAnimation { properties: "scale"; duration: 1000; to: 1; }
+ }
+ add: Transition {
+ NumberAnimation {
+ properties: "scale"; duration: 1000; from: 0; to: 1;
+ }
+ }
+ remove: Transition {
+ NumberAnimation {
+ properties: "scale"; duration: 1000; to: 0;
+ }
+ }
+ Layout.fillHeight: true;
+ width: 100;
+ }
+ }
+}
diff --git a/qml/Plumb.qml b/qml/Plumb.qml
new file mode 100644
--- /dev/null
+++ b/qml/Plumb.qml
@@ -0,0 +1,168 @@
+import QtQuick 2.0
+import QtGraphicalEffects 1.0
+
+Item {
+ id: c;
+ width: tileSize;
+ height: tileSize;
+
+ property double tileSize : 100;
+ property double internalTileSize : 100;
+
+ property var entryA : null;
+ property var exitA : null;
+ property double volume : 0;
+ property color colour : 'green';
+ property string label : '';
+
+ property string _maskSource : '';
+ property int _maskRotation : 0;
+ property string _maskLetter : '';
+
+ function setup() {
+ var source = '', rotation = 0, letter = '';
+ if (rotate(c.entryA, 180) == c.exitA) {
+ source = 'straight';
+ rotation = c.entryA;
+ }
+ else if (rotate(c.entryA, 90) == c.exitA) {
+ source = 'corner';
+ rotation = c.entryA;
+ }
+ else if (rotate(c.exitA, 90) == c.entryA) {
+ source = 'corner';
+ rotation = c.exitA;
+ }
+ else if (isOrtho(c.entryA) && !isOrtho(c.exitA)) {
+ source = 'end';
+ rotation = c.entryA;
+ letter = 'E';
+ }
+ else if (isOrtho(c.exitA) && !isOrtho(c.entryA)) {
+ source = 'end';
+ rotation = c.exitA;
+ letter = 'S';
+ }
+ else {
+ source = 'full';
+ letter = 'X';
+ }
+ c._maskSource = source;
+ c._maskRotation = rotation;
+ c._maskLetter = letter;
+ }
+ Component.onCompleted: setup();
+ onEntryAChanged: setup();
+ onExitAChanged: setup();
+
+ function rotate(a, d) {
+ return isOrtho(a) ? (a+d)%360 : -1;
+ }
+
+ function isOrtho(a) {
+ return a == 0 || a == 90 || a == 180 || a == 270;
+ }
+
+ DropShadow {
+ anchors.fill: c;
+ radius: 0.025*c.tileSize;
+ spread: 0.8;
+ fast: true;
+ color: 'black';
+ opacity: 0.2;
+ source: uncached_mask;
+ layer.enabled: true;
+ clip: true;
+ }
+ LinearGradient {
+ function steer(n, dir) {
+ switch (dir) {
+ case 0: return {x: 0.5, y: n};
+ case 90: return {x: 1-n, y: 0.5};
+ case 180: return {x: 0.5, y: 1-n};
+ case 270: return {x: n, y: 0.5};
+ }
+ return {x: 0.5, y: 0.5};
+ }
+
+ function point(p) {
+ return Qt.point(p.x*c.width, p.y*c.height);
+ }
+
+ function calc(vol, t, ena, exa) {
+ var band = 0.3;
+ var t2 = t + band;
+ if (!isOrtho(ena)) {
+ vol = 0.4+vol*0.6;
+ ena = rotate(exa, 180);
+ }
+ else if (!isOrtho(exa)) {
+ vol = vol*0.6;
+ exa = rotate(ena, 180);
+ }
+ exa = rotate(exa, 180);
+ if (vol < t) {
+ return point(steer(vol, ena));
+ }
+ else if (vol < t2) {
+ var v = (vol-t)/band;
+ var a = steer(t, ena);
+ var b = steer(t2, exa);
+ return point({x: a.x*(1-v)+b.x*v, y: a.y*(1-v)+b.y*v});
+ }
+ else {
+ return point(steer(vol, exa));
+ }
+ }
+
+ id: grad;
+ anchors.fill: parent;
+ start: calc(c.volume-0.1, 0.3, c.entryA, c.exitA);
+ end: calc(c.volume, 0.4, c.entryA, c.exitA);
+ gradient: Gradient {
+ GradientStop { position: 0.0; color: colour; }
+ GradientStop { position: 1.0; color: Qt.rgba(0,0,0,0.1); }
+ }
+ source: mask;
+ }
+ Item {
+ id: mask;
+ anchors.fill: parent; visible: false;
+ layer.enabled: true;
+ Item {
+ id: uncached_mask;
+ anchors.fill: parent;
+ Image {
+ anchors.fill: parent;
+ rotation: c._maskRotation;
+ source: c._maskSource + '_mask.svg';
+ sourceSize.width: c.internalTileSize;
+ sourceSize.height: c.internalTileSize;
+ }
+ }
+ }
+ Item {
+ anchors.fill: parent;
+ visible: c._maskLetter != '';
+ Text {
+ anchors.centerIn: parent;
+ font.pixelSize: 0.2*c.tileSize;
+ text: c._maskLetter;
+ color: c.colour.r + c.colour.g + c.colour.b > 1.5 ?
+ Qt.darker(c.colour, 2) : Qt.lighter(c.colour, 2);
+ }
+ Item {
+ anchors.fill: parent;
+ rotation: rotate(c._maskRotation, 270) % 180;
+ Text {
+ x: rotate(c._maskRotation,90) <= 90 ? 0 : 0.4*c.tileSize;
+ y: 0.25*c.tileSize;
+ width: 0.6*c.tileSize;
+ horizontalAlignment: rotate(c._maskRotation,90) <= 90 ?
+ Text.AlignRight : Text.AlignLeft;
+ font.pixelSize: 0.1*c.tileSize;
+ text: c.label;
+ }
+ }
+ }
+}
diff --git a/qml/corner_mask.svg b/qml/corner_mask.svg
new file mode 100644
--- /dev/null
+++ b/qml/corner_mask.svg
@@ -0,0 +1,5 @@
+
+
diff --git a/qml/end_mask.svg b/qml/end_mask.svg
new file mode 100644
--- /dev/null
+++ b/qml/end_mask.svg
@@ -0,0 +1,6 @@
+
+
+
diff --git a/qml/full_mask.svg b/qml/full_mask.svg
new file mode 100644
--- /dev/null
+++ b/qml/full_mask.svg
@@ -0,0 +1,6 @@
+
+
+
diff --git a/qml/mouse.svg b/qml/mouse.svg
new file mode 100644
--- /dev/null
+++ b/qml/mouse.svg
@@ -0,0 +1,6 @@
+
+
+
diff --git a/qml/straight_mask.svg b/qml/straight_mask.svg
new file mode 100644
--- /dev/null
+++ b/qml/straight_mask.svg
@@ -0,0 +1,6 @@
+
+
+
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,440 @@
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, TypeFamilies #-}
+module Main where
+
+import Control.Concurrent (forkIO)
+import Control.Exception (evaluate)
+import Control.Applicative ((<$>))
+import Control.Monad
+import Control.Monad.Random
+import Data.Function
+import Data.Typeable
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.List
+import Graphics.QML
+import Graphics.QML.Objects.ParamNames
+
+import Paths_hsqml_demo_manic
+
+data Bearing = North | East | South | West
+ deriving (Typeable, Eq, Enum, Bounded, Show, Read)
+
+instance Marshal Bearing where
+ type MarshalMode Bearing c d = ModeTo c
+ marshaller = toMarshaller (\x -> case x of
+ North -> 0 :: Int
+ East -> 90
+ South -> 180
+ West -> 270)
+
+data Orientation =
+ Horizontal | Vertical deriving (Eq, Enum, Bounded, Show, Read)
+
+data Colour = Green | Yellow | Brown | Blue
+ deriving (Typeable, Eq, Enum, Bounded, Show, Read)
+
+instance Marshal Colour where
+ type MarshalMode Colour c d = ModeTo c
+ marshaller = toMarshaller (\x -> case x of
+ Green -> T.pack "lime" :: Text
+ Yellow -> T.pack "yellow"
+ Brown -> T.pack "darkgoldenrod"
+ Blue -> T.pack "blue")
+
+data Tile
+ = Start Colour Bearing
+ | End Colour Bearing
+ | Corner Bearing
+ | Straight Orientation
+ | Cross
+ deriving (Eq, Show, Read)
+
+data NumberedTile = NumberedTile Tile Int deriving Typeable
+
+newtype TileSource = TileSource [NumberedTile] deriving Typeable
+
+instance Marshal NumberedTile where
+ type MarshalMode NumberedTile c d = ModeObjBidi NumberedTile c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+instance DefaultClass NumberedTile where
+ classMembers = [
+ defPropertyConst "tile" (\(NumberedTile tile _) -> return tile),
+ defPropertyConst "idx" (\(NumberedTile _ idx) -> return idx)]
+
+instance Marshal TileSource where
+ type MarshalMode TileSource c d = ModeObjBidi TileSource c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+instance DefaultClass TileSource where
+ classMembers = [
+ defPropertyConst "top" (\(TileSource ts) -> return $ head ts),
+ defPropertyConst "next" (\(TileSource ts) ->
+ return $ TileSource $ tail ts),
+ defMethod "topN" (\(TileSource ts) n ->
+ return $ take n ts :: IO [NumberedTile])]
+
+newTileSource :: IO TileSource
+newTileSource = do
+ g <- newStdGen
+ return $ TileSource $ zipWith NumberedTile (randomTiles g) [0..]
+
+randomEnum :: forall g e. (RandomGen g, Enum e, Bounded e) => Rand g e
+randomEnum = toEnum <$> getRandomR (fromEnum lo, fromEnum hi)
+ where lo = minBound :: e
+ hi = maxBound :: e
+
+randomTile :: (RandomGen g) => Rand g Tile
+randomTile = join $ fromList [
+ (fmap Corner randomEnum, 4),
+ (fmap Straight randomEnum, 2),
+ (return Cross, 1)]
+
+randomTiles :: (RandomGen g) => g -> [Tile]
+randomTiles = unfoldr (Just . runRand randomTile)
+
+instance Marshal Tile where
+ type MarshalMode Tile c d = ModeBidi c
+ marshaller = bidiMarshaller (read . T.unpack) (T.pack . show)
+
+data Point = Pt !Int !Int deriving (Typeable, Eq, Ord, Show)
+
+instance DefaultClass Point where
+ classMembers = [
+ defPropertyConst "x" (\(Pt x _) -> return x),
+ defPropertyConst "y" (\(Pt _ y) -> return y)]
+
+instance Marshal Point where
+ type MarshalMode Point c d = ModeObjBidi Point c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+data Grid = Grid Int Int (Map Point Tile) deriving (Typeable, Show)
+
+place :: Point -> Tile -> Grid -> Grid
+place pt tile (Grid w h grid) = Grid w h $ Map.insert pt tile grid
+
+placeIfFree :: Point -> Tile -> Grid -> Grid
+placeIfFree pt tile (Grid w h grid) = Grid w h $ Map.alter (\oldTile ->
+ if isJust oldTile then oldTile else Just tile) pt grid
+
+data PickedSignal deriving Typeable
+
+instance SignalKeyClass PickedSignal where
+ type SignalParams PickedSignal = Point -> IO ()
+
+instance DefaultClass Grid where
+ classMembers = [
+ defPropertyConst "width" (\(Grid w _ _) -> return w),
+ defPropertyConst "height" (\(Grid _ h _) -> return h),
+ defMethod "place" (\grid x y tile ->
+ return $ place (Pt x y) tile grid :: IO Grid),
+ defMethod "plumb" (return . plumbGrid :: Grid -> IO PlumbedGrid),
+ defMethod "pick" (\grid tiles currX currY vol -> void $ forkIO $ do
+ let (Pt x y) = pickMove (fromObjRef grid) tiles (Pt currX currY) vol
+ x' <- evaluate x
+ y' <- evaluate y
+ let pos = Pt x' y'
+ fireSignal (Proxy :: Proxy PickedSignal) grid pos),
+ defSignalNamedParams "picked" (Proxy :: Proxy PickedSignal) $
+ fstName "pos"]
+
+instance Marshal Grid where
+ type MarshalMode Grid c d = ModeObjBidi Grid c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+data PlumbedGrid = PlumbedGrid [Plumb] [Leak] (Map Point Int)
+ deriving Typeable
+
+isPlacable :: PlumbedGrid -> Int -> Point -> Bool
+isPlacable (PlumbedGrid _ _ indexMap) n pt =
+ maybe True (> n) $ Map.lookup pt indexMap
+
+instance DefaultClass PlumbedGrid where
+ classMembers = [
+ defPropertyConst "plumbing" (\(PlumbedGrid ps _ _) -> return ps),
+ defPropertyConst "leaks" (\(PlumbedGrid _ ls _) -> return ls),
+ defPropertyConst "maxIndex" (\(PlumbedGrid ps _ _) ->
+ return . minimum . filter (>= 0) .
+ map (maximum . map (\(Plumb _ i _ _ _) -> i)) $
+ groupBy ((==) `on` (\(Plumb c _ _ _ _) -> c)) ps),
+ defMethod "isPlacable" (\pGrid n x y ->
+ return $ isPlacable pGrid n (Pt x y) :: IO Bool)]
+
+instance Marshal PlumbedGrid where
+ type MarshalMode PlumbedGrid c d = ModeObjBidi PlumbedGrid c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+data Plumb = Plumb Colour Int Point (Maybe Bearing) (Maybe Bearing)
+ deriving (Typeable, Show)
+
+instance DefaultClass Plumb where
+ classMembers = [
+ defPropertyConst "colour" (\(Plumb col _ _ _ _) -> return col),
+ defPropertyConst "idx" (\(Plumb _ idx _ _ _) -> return idx),
+ defPropertyConst "x" (\(Plumb _ _ (Pt x _) _ _) -> return x),
+ defPropertyConst "y" (\(Plumb _ _ (Pt _ y) _ _) -> return y),
+ defPropertyConst "entryA" (\(Plumb _ _ _ theta _) -> return theta),
+ defPropertyConst "exitA" (\(Plumb _ _ _ _ theta) -> return theta)]
+
+instance Marshal Plumb where
+ type MarshalMode Plumb c d = ModeObjBidi Plumb c
+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC
+
+newtype Leak = Leak {unLeak :: Plumb}
+
+instance Marshal Leak where
+ type MarshalMode Leak c d = ModeObjBidi Plumb c
+ marshaller = bidiMarshaller Leak unLeak
+
+bend :: Bearing -> Bearing
+bend North = East
+bend East = South
+bend South = West
+bend West = North
+
+invert :: Bearing -> Bearing
+invert = bend . bend
+
+revBend :: Bearing -> Bearing
+revBend = bend . bend . bend
+
+nextPos :: Maybe Bearing -> Point -> Point
+nextPos (Just North) (Pt x y) = Pt x (y-1)
+nextPos (Just East) (Pt x y) = Pt (x+1) y
+nextPos (Just South) (Pt x y) = Pt x (y+1)
+nextPos (Just West) (Pt x y) = Pt (x-1) y
+nextPos Nothing p = p
+
+plumbTile :: (Point -> Maybe Tile) -> PrePlumb -> Maybe Plumb
+plumbTile getTile (PrePlumb col idx curr flow) = case getTile curr of
+ Just (Start c theta)
+ | flow == Nothing && col == c ->
+ Just $ Plumb col idx curr Nothing (Just theta)
+ Just (End c theta)
+ | flow == Just (invert theta) && col == c ->
+ Just $ Plumb col idx curr (Just theta) Nothing
+ Just (Straight Horizontal)
+ | flow == Just East || flow == Just West ->
+ Just $ Plumb col idx curr (fmap invert flow) flow
+ Just (Straight Vertical)
+ | flow == Just North || flow == Just South ->
+ Just $ Plumb col idx curr (fmap invert flow) flow
+ Just (Corner theta)
+ | flow == Just (invert theta) ->
+ Just $ Plumb col idx curr (Just theta) (Just $ bend theta)
+ | flow == Just (revBend theta) ->
+ Just $ Plumb col idx curr (Just $ bend theta) (Just theta)
+ Just Cross -> Just $ Plumb col idx curr (fmap invert flow) flow
+ _ -> Nothing
+
+data Terminal = Success | EmptyTile | BadPipe deriving Show
+
+data PrePlumb = PrePlumb Colour Int Point (Maybe Bearing) deriving Show
+
+unPlumb :: Plumb -> PrePlumb
+unPlumb (Plumb col idx curr inflow _) =
+ PrePlumb col idx curr (fmap invert inflow)
+
+plumbOn :: Plumb -> PrePlumb
+plumbOn (Plumb col idx curr _ flow) =
+ PrePlumb col (idx+1) (nextPos flow curr) flow
+
+plumbStep ::
+ (Point -> Maybe Tile) -> PrePlumb -> Either Terminal (Plumb, PrePlumb)
+plumbStep tileFn pre@(PrePlumb _ _ curr flow) = case tileFn curr of
+ Just _ -> case plumbTile tileFn pre of
+ Just plumb -> Right (plumb, plumbOn plumb)
+ Nothing -> maybe (Left Success) (const $ Left BadPipe) flow
+ Nothing -> Left EmptyTile
+
+unfoldrEither :: (b -> Either c (a, b)) -> b -> (c, [a])
+unfoldrEither f b = case f b of
+ Right (a,b') -> (a:) <$> unfoldrEither f b'
+ Left c -> (c, [])
+
+plumbStart :: Grid -> Colour -> Point -> Maybe Bearing -> (Terminal, [Plumb])
+plumbStart (Grid _ _ grid) col start flow =
+ unfoldrEither (plumbStep (`Map.lookup` grid)) $
+ PrePlumb col 0 start flow
+
+plumbAllStarts :: Grid -> [[Plumb]]
+plumbAllStarts grid = foldStarts (\col curr ps ->
+ snd (plumbStart grid col curr Nothing) : ps) [] grid
+
+foldStarts :: (Colour -> Point -> a -> a) -> a -> Grid -> a
+foldStarts f s (Grid _ _ gridMap) =
+ Map.foldWithKey (\curr tile a -> case tile of
+ Start col _ -> f col curr a
+ _ -> a) s gridMap
+
+plumbLeak :: [Plumb] -> Maybe Leak
+plumbLeak ps =
+ case last ps of
+ Plumb col idx end _ (Just flow) ->
+ Just $ Leak $ Plumb col (idx+1) end Nothing $ Just flow
+ _ -> Nothing
+
+stripPlumbed :: [Plumb] -> Grid -> Grid
+stripPlumbed ps (Grid w h grid) =
+ Grid w h $ foldl' (flip $ \(Plumb _ _ p theta _) ->
+ Map.update (f theta) p) grid ps
+ where f (Just North) Cross = Just $ Straight Horizontal
+ f (Just East) Cross = Just $ Straight Vertical
+ f (Just South) Cross = Just $ Straight Horizontal
+ f (Just West) Cross = Just $ Straight Vertical
+ f _ _ = Nothing
+
+spareParts :: Grid -> [Plumb]
+spareParts (Grid _ _ grid) =
+ Map.foldWithKey sparePart [] grid
+
+sparePart :: Point -> Tile -> [Plumb] -> [Plumb]
+sparePart p (Start col theta) xs = Plumb col (-1) p Nothing (Just theta) : xs
+sparePart p (End col theta) xs = Plumb col (-1) p (Just theta) Nothing : xs
+sparePart p (Corner theta) xs =
+ Plumb Green (-1) p (Just theta) (Just $ bend theta) : xs
+sparePart p (Straight Horizontal) xs =
+ Plumb Green (-1) p (Just East) (Just West) : xs
+sparePart p (Straight Vertical) xs =
+ Plumb Green (-1) p (Just North) (Just South) : xs
+sparePart p Cross xs =
+ Plumb Green (-1) p (Just East) (Just West) :
+ Plumb Green (-1) p (Just North) (Just South) : xs
+
+buildIndexMap :: [Plumb] -> Map Point Int
+buildIndexMap = foldr (\plumb gridMap -> case plumb of
+ Plumb _ i p _ (Just _) -> Map.alter (Just . maybe i (min i)) p gridMap
+ Plumb _ _ p _ Nothing -> Map.insert p (-1) gridMap) Map.empty
+
+plumbGrid :: Grid -> PlumbedGrid
+plumbGrid grid =
+ let plumbs = plumbAllStarts grid
+ leaks = mapMaybe plumbLeak plumbs
+ indexMap = buildIndexMap $ plumb ++ filter (\(Plumb _ _ _ _ flow) ->
+ isNothing flow) spares
+ plumb = concat plumbs
+ spares = spareParts $ stripPlumbed plumb grid
+ in PlumbedGrid (plumb ++ spares) leaks indexMap
+
+nextPosFollowPlumb :: Grid -> Colour -> Point -> Maybe Bearing -> [PrePlumb]
+nextPosFollowPlumb grid@(Grid w h _) col start flow =
+ dropOutOfBounds $ case reverse <$> plumbStart grid col start flow of
+ (EmptyTile, []) -> [PrePlumb col 0 start flow]
+ (EmptyTile, ps) -> plumbOn (head ps) : map unPlumb ps
+ (Success, ps) -> map unPlumb ps
+ _ -> []
+ where dropOutOfBounds pps@(PrePlumb _ _ (Pt x y) _:_) =
+ if x >= 0 && y >=0 && x < w && y < h then pps else []
+ dropOutOfBounds [] = []
+
+neighbours :: Grid -> Colour -> Point -> [[PrePlumb]]
+neighbours grid@(Grid _ _ gridMap) col start =
+ filter (not . null) $ case Map.lookup start gridMap of
+ Just _ -> [nextPosFollowPlumb grid col start Nothing]
+ Nothing -> map ((\flow ->
+ nextPosFollowPlumb grid col (nextPos flow start) flow) . Just)
+ [North,East,South,West]
+
+findCosts ::
+ Grid -> Colour -> Point -> Map Point (Int, [PrePlumb])
+findCosts grid col start =
+ fst $ fromJust $ find (null . snd) $
+ iterate explore (Map.empty, [(start, [], -1)])
+ where explore (cache, open) =
+ foldr update (cache, []) open
+ update (curr, pps, cost') (cache, open) =
+ case fromMaybe (maxBound, []) $ Map.lookup curr cache of
+ (cost, _) | cost' < cost ->
+ (Map.insert curr (cost', pps) cache,
+ map (\pps'@(PrePlumb _ _ curr' _:_) ->
+ (curr', pps' ++ pps, cost' + 1))
+ (neighbours grid col curr) ++ open)
+ _ -> (cache, open)
+
+findGoal ::
+ Grid -> Map Point (Int, a) -> Colour -> Maybe (Point, Int, a)
+findGoal (Grid _ _ gridMap) costs col =
+ fmap (\((a,b),c) -> (a,c,b)) $
+ foldr (\(curr,(cost,x)) prevBest -> case prevBest of
+ Just best | cost >= snd best -> prevBest
+ _ -> Just ((curr,x),cost)) Nothing $
+ Map.toList $ Map.mapMaybeWithKey (\curr tile ->
+ case tile of
+ End col' _ | col' == col -> Map.lookup curr costs
+ _ -> Nothing) gridMap
+
+findPath :: Grid -> Colour -> Point -> Maybe ([Plumb], Int)
+findPath grid col start =
+ let costs = findCosts grid col start
+ goal = findGoal grid costs col
+ in fmap (\(_,cost,pps) -> (plumbPre $ reverse pps,cost)) goal
+
+plumbPre :: [PrePlumb] -> [Plumb]
+plumbPre pps = zipWith3 f pps (tail pps) [0..]
+ where f (PrePlumb col _ curr flow) (PrePlumb _ _ _ nextFlow) idx =
+ Plumb col idx curr (fmap invert flow) nextFlow
+
+gridHeuristic :: Int -> Grid -> Int
+gridHeuristic vol grid = snd $ foldStarts (\col start (grid',heur) ->
+ let plumbedLen = length $ snd $ plumbStart grid' col start Nothing
+ (path, pathLen) = fromMaybe ([], 1000) $ findPath grid' col start
+ remain = min (plumbedLen - vol) 4
+ bonus = 9*remain - (remain*remain)
+ grid'' = foldr placePlumb grid' path
+ in (grid'', heur + 2*bonus + 4*plumbedLen - pathLen)) (grid, 0) grid
+
+pickMove :: Grid -> TileSource -> Point -> Int -> Point
+pickMove grid (TileSource (NumberedTile tile _:_)) start vol =
+ fst $ head $ sortMoves start vol $ searchMoves grid vol tile
+
+searchMoves :: Grid -> Int -> Tile -> [(Point, Grid)]
+searchMoves grid@(Grid w h _) vol tile =
+ map (\pt -> (pt, place pt tile grid)) $
+ filter (isPlacable pGrid vol) $ liftM2 Pt [0..w-1] [0..h-1]
+ where pGrid = plumbGrid grid
+
+sortMoves :: Point -> Int -> [(Point, Grid)] -> [(Point, Grid)]
+sortMoves start vol =
+ map fst . sortBy (flip compare `on` snd) .
+ map (\x -> (,) x $ (+ (distance start (fst x) / (-100.0))) $ fromIntegral $ gridHeuristic vol $ snd x)
+
+distance :: Point -> Point -> Double
+distance (Pt x1 y1) (Pt x2 y2) =
+ sqrt $ (x*x)+(y*y)
+ where x = fromIntegral (x1-x2)
+ y = fromIntegral (y1-y2)
+
+placePlumb :: Plumb -> Grid -> Grid
+placePlumb (Plumb _ _ curr (Just inflow) (Just flow))
+ | inflow == bend flow = placeIfFree curr $ Corner flow
+ | inflow == revBend flow = placeIfFree curr $ Corner inflow
+ | otherwise = placeIfFree curr Cross
+placePlumb _ = id
+
+debugMain :: Grid -> IO ()
+debugMain myGrid = do
+ clazz <- newClass [
+ defMethod' "newTileSource" (\_ -> newObjectDC =<< newTileSource),
+ defMethod' "newGrid" (\_ -> newObjectDC myGrid),
+ defMethod' "sparePart" (\_ tile ->
+ return $ sparePart (Pt 0 0) tile [] :: IO [Plumb])]
+ object <- newObject clazz ()
+ -- setQtArgs "hsqml-manic" ["-qmljsdebugger=port:9999,block"]
+ qml <- getDataFileName "Main.qml"
+ runEngineLoop $ defaultEngineConfig {
+ initialDocument = fileDocument qml,
+ contextObject = Just $ anyObjRef object
+ }
+
+newGrid :: Grid
+newGrid = Grid 8 8 $ Map.fromList [
+ (Pt 4 0,Start Yellow South),
+ (Pt 3 7,End Yellow North),
+ (Pt 0 3, Start Brown East),
+ (Pt 7 4, End Brown West)]
+
+main :: IO ()
+main = debugMain newGrid