INblobs 0.1 → 0.1.1
raw patch · 42 files changed
+10307/−2 lines, 42 files
Files
- INblobs.cabal +45/−2
- INblobs.xsd +460/−0
- html/HowToUse.html +67/−0
- src/Colors.hs +84/−0
- src/Common.hs +216/−0
- src/CommonIO.hs +333/−0
- src/CommonUI.hs +1220/−0
- src/Constants.hs +64/−0
- src/ContextMenu.hs +147/−0
- src/DisplayOptions.hs +16/−0
- src/Document.hs +187/−0
- src/DocumentFile.hs +145/−0
- src/Functional/Compiler.hs +539/−0
- src/Functional/Language.hs +204/−0
- src/Functional/Parser.hs +145/−0
- src/Functional/UI.hs +226/−0
- src/GUIEvents.hs +243/−0
- src/INChecks.hs +519/−0
- src/INChecksUI.hs +257/−0
- src/INReduction.hs +256/−0
- src/INReductionStrategies.hs +96/−0
- src/INRule.hs +144/−0
- src/INRules.hs +69/−0
- src/INTextual.hs +315/−0
- src/INTextualUI.hs +143/−0
- src/InfoKind.hs +27/−0
- src/Math.hs +114/−0
- src/Network.hs +662/−0
- src/NetworkControl.hs +534/−0
- src/NetworkFile.hs +465/−0
- src/NetworkUI.hs +565/−0
- src/NetworkView.hs +418/−0
- src/Operations.hs +68/−0
- src/PDDefaults.hs +91/−0
- src/Palette.hs +42/−0
- src/PersistentDocument.hs +338/−0
- src/Ports.hs +117/−0
- src/SafetyNet.hs +24/−0
- src/Shape.hs +313/−0
- src/SpecialSymbols.hs +111/−0
- src/State.hs +248/−0
- src/StateUtil.hs +30/−0
INblobs.cabal view
@@ -1,5 +1,5 @@ Name: INblobs-Version: 0.1+Version: 0.1.1 License: LGPL License-file: LICENCE-LGPL Author: Arjan van IJzendoorn, Martijn Schrage, Malcolm Wallace, Miguel Vilaca@@ -15,6 +15,8 @@ Category: Compilers/Interpreters +Data-files: INblobs.xsd, html/HowToUse.html+ Build-type: Simple Cabal-Version: >=1.2 @@ -28,6 +30,47 @@ else Build-Depends: base < 3 - Hs-Source-Dirs: src+ Hs-Source-Dirs: src+ Other-Modules:+ Colors+ Common+ CommonIO+ CommonUI+ Constants+ ContextMenu+ DisplayOptions+ Document+ DocumentFile+ GUIEvents+ INChecks+ INChecksUI+ INReduction+ INReductionStrategies+ INRule+ INRules+ INTextual+ INTextualUI+ InfoKind+ Math+ Network+ NetworkControl+ NetworkFile+ NetworkUI+ NetworkView+ Operations+ PDDefaults+ Palette+ PersistentDocument+ Ports+ SafetyNet+ Shape+ SpecialSymbols+ State+ StateUtil+ Functional.Compiler+ Functional.Language+ Functional.Parser+ Functional.UI+ Extensions: ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ParallelListComp
+ INblobs.xsd view
@@ -0,0 +1,460 @@+<?xml version = '1.0' encoding = 'UTF-8'?>+<!-- edited with XMLSpy v2008 sp1 (http://www.altova.com) by Miguel (University of Minho) --><!--W3C Schema generated by XMLSpy v2008 sp1 (http://www.altova.com)--><xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Document" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">INblobs file</xs:documentation>+ </xs:annotation>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="NetworkType" name="Network" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Main net</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Palette" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" name="Symbol" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="ShapeName" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Shape" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:group xmlns:xs="http://www.w3.org/2001/XMLSchema" ref="Shapes" />+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Ports" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Principals" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PortType" name="Port" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Auxiliaries" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" type="PortType" minOccurs="0" name="Port" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Info" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="maybe-list-intType" name="maybe-list-int" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Rules" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" minOccurs="1" name="INRule" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="Name" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="LHS" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="NetworkType" name="Network" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="RHS" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="NetworkType" name="Network" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Mapping" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Interface agents correspondence between LHS and RHS</xs:documentation>+ </xs:annotation>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" minOccurs="0" name="MappingElement" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:string" name="lhs" />+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:string" name="rhs" />+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="NetworkType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Info" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="unit" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema"/>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Nodes" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" minOccurs="0" name="Node" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="Name" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="LabelAbove" >+ <xs:simpleType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:restriction xmlns:xs="http://www.w3.org/2001/XMLSchema" base="xs:string" >+ <xs:enumeration xmlns:xs="http://www.w3.org/2001/XMLSchema" value="True" />+ <xs:enumeration xmlns:xs="http://www.w3.org/2001/XMLSchema" value="False" />+ </xs:restriction>+ </xs:simpleType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="Shape" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Shape name</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Info" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-intType" name="list-int" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:string" name="id" />+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Edges" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" minOccurs="0" name="Edge" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="From" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Node number</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="PortFrom" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Port name</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="To" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Node number</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="PortTo" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Port name</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Via" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Middle points for edge</xs:documentation>+ </xs:annotation>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" type="PositionType" minOccurs="0" name="Position" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Info" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-intType" name="list-int" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:string" name="id" />+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:double" name="Width" />+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:double" name="Height" />+ </xs:complexType>+ <xs:simpleType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="colourInt" final="restriction" >+ <xs:restriction xmlns:xs="http://www.w3.org/2001/XMLSchema" base="xs:int" >+ <xs:minInclusive xmlns:xs="http://www.w3.org/2001/XMLSchema" value="0" />+ <xs:maxInclusive xmlns:xs="http://www.w3.org/2001/XMLSchema" value="255" />+ </xs:restriction>+ </xs:simpleType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="PositionType" >+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:double" name="Y" />+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:double" name="X" />+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="PortType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="string" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Port name</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" />+ </xs:sequence>+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="RGBType" >+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="colourInt" name="R" />+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="colourInt" name="G" />+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="colourInt" name="B" />+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="list-intType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" type="intType" minOccurs="0" name="int" />+ </xs:sequence>+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="ShapeStyleType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="intType" name="int" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="RGBType" name="RGB" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="RGBType" name="RGB" />+ </xs:sequence>+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="maybe-list-intType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-intType" minOccurs="0" name="list-int" />+ </xs:sequence>+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="doubleType" >+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:double" name="value" />+ </xs:complexType>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="list-DoublePointType" >+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" type="PositionType" minOccurs="0" name="Position" />+ </xs:sequence>+ </xs:complexType>+ <xs:group xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Shapes" >+ <xs:choice xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Circle" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Polygon" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-DoublePointType" name="list-DoublePoint" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Perimeter points</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Lines" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-DoublePointType" name="list-DoublePoint" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Perimeter points</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Points" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="list-DoublePointType" name="list-DoublePoint" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Points</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Rectangle" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Upper left point</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Lower right point</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Arc" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Start</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">End</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Center point</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Ellipse" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Center point</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Horizontal radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Vertical radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="EllipticArc" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Center point</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Horizontal radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Vertical radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Start</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">End</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="RoundRec" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="doubleType" name="double" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Radius</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Upper left point</xs:documentation>+ </xs:annotation>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="PositionType" name="Position" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Lower right point</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Text" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="string" />+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="Composite" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="list-Shape" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:group xmlns:xs="http://www.w3.org/2001/XMLSchema" maxOccurs="unbounded" minOccurs="0" ref="Shapes" />+ </xs:complexType>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" name="TextInEllipse" >+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:sequence xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="ShapeStyleType" name="ShapeStyle" />+ <xs:element xmlns:xs="http://www.w3.org/2001/XMLSchema" type="xs:string" name="string" >+ <xs:annotation xmlns:xs="http://www.w3.org/2001/XMLSchema">+ <xs:documentation xmlns:xs="http://www.w3.org/2001/XMLSchema">Text</xs:documentation>+ </xs:annotation>+ </xs:element>+ </xs:sequence>+ </xs:complexType>+ </xs:element>+ </xs:choice>+ </xs:group>+ <xs:complexType xmlns:xs="http://www.w3.org/2001/XMLSchema" name="intType" >+ <xs:attribute xmlns:xs="http://www.w3.org/2001/XMLSchema" use="required" type="xs:int" name="value" />+ </xs:complexType>+</xs:schema>
+ html/HowToUse.html view
@@ -0,0 +1,67 @@+<html>+<head>+ <title>INblobs editor</title>+ <meta name="keywords" content="IN, Interaction Nets, editor, INblobs" />+ <meta name="description" content="Free Interaction Nets editor." />+</head>++<body>+<h3>How to use INblobs</h3>+<p>+<ul>+<li> Select an agent symbol by pressing its button on the left panel (symbol palette).+<br /><br />+<li> Right click (or ctrl-click) on a canvas, node, or edge for a context menu.+<br /><br />+<li> To create a node, shift click on some blank canvas.+<br /><br />+<li> To create an edge, select (click) the source port, then shift-click+ the target port.+<br /><br />+<li> To delete a node or edge, select it and press BACKSPACE or DEL, or else use the context menu.+<br /><br />+<li> To rearrange the diagram, click and drag nodes to where you want them.+<br /><br />+<li> To make an edge look tidier, add a control-point from its context menu,+ and drag the point to where you want it.+<br /><br />+<li> You can add multiple items into the current selection by meta-clicking+ the extra nodes and control points. (Meta = Apple key, or CONTROL key.)+ A multiple selection can be dragged or deleted just like a single selection.+<br /><br />+<li> The interface of a net or a rule is explicitly defined by means of special interface agents.+<br /><br />+<li> The net on the bottom is the net to be reduced or converted to a textual configuration.+<br /><br />+<li> The two nets in the top are the left-hand side and right-hand side of the+ interaction rule currently selected (from the list of rules on the left).+<br /><br />+<li> To add a new rule press button <b>Add new rule</b> or else do mouse+ right-click in <b>Rules</b> (the root of the tree of rules). Then add+ agents to the canvas on the top.+<br /><br />+<li> Alternatively, use the <b>Rule creation wizard</b>. Pressing this button will+ make a dialog appear where the two agents that will interact can be + chosen. The wizard will automatically generate the left-hand side of+ the rule. It is also possible to choose what is generated in the + right-hand side of the rule:+ <ul>+ <li> a copy of the left-hand side to be manually edited after + (useful for rules with similar sides);+ <li> the interface agents from left-hand side;+ <li> nothing ( generates a blank right-hand side, not recommended)+ </ul>+<br />+<li> For rules between one of <b>{&epsilon, &delta, c}</b> symbols and any symbol there are templates that automatically create the whole rule; in <b>Rule creation wizard</b> check option <b>Rule template</b> and choose the two symbols.+<br/>+<li> Match interface agents in a rule by selecting the desired interface agent+ in the left-hand side and shift-clicking the corresponding interface agent+ in the right-hand side. A box with the same number will appear in both agents.+<br /><br />+<li> Edge and node labels can be made visible by selecting the appropriate command+ from the <b>View</b> menu. Edge labels are useful since they make the selection+ of edges easier: to select an edge just click on its label.+</ul>+<a href="../index.html">back to main page</a>+</body>+</html>
+ src/Colors.hs view
@@ -0,0 +1,84 @@+module Colors where++import Graphics.UI.WX+import Text.Parse++-- Different spelling of colour/color to distinguish local/wx datatypes.+data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read)++instance Parse Colour where+ parse = do { isWord "RGB"+ ; return RGB `apply` parse `apply` parse `apply` parse+ }++-- translate local to wx+wxcolor :: Colour -> Color+wxcolor (RGB r g b) = rgb r g b++nodeColor, labelBackgroundColor, evidenceColor, evidenceHatchColor,+ wrongProbabilitiesColor, paneBackgroundColor, activeSelectionColor,+ inactiveSelectionColor :: Colour+nodeColor = lightBlue+evidenceColor = lightYellow+evidenceHatchColor = licorice+labelBackgroundColor = lightYellow+paneBackgroundColor = coconut+activeSelectionColor = licorice+inactiveSelectionColor = lightGrey+wrongProbabilitiesColor = lightRed++testSelectionTestColor, testSelectionTargetColor :: Colour+testSelectionTestColor = RGB 0 255 0+testSelectionTargetColor = RGB 255 0 0++lightYellow, lightBlue, lightRed, lightGrey, pink :: Colour+lightYellow = RGB 236 236 169+lightBlue = RGB 200 255 255+lightGrey = RGB 150 150 150+lightRed = RGB 255 200 200+pink = RGB 255 200 200++systemGrey :: Color -- wx type+systemGrey = colorSystem Color3DFace++licorice, coconut :: Colour -- names black and white already taken by wx+licorice = RGB 0 0 0+coconut = RGB 255 255 255++darkGreen, darkBlue, violet, indigo, darkRed, darkMagenta, darkOrange,+ orange, lightPink, purple, lightGreen, mediumPurple, darkViolet, gray,+ darkGrey, darkGray, lightGray, silver, whiteSmoke, aqua, teal, maroon,+ olive, sienna, brown, fuchsia, turquoise, orangeRed, gold,darkSlateGray+ :: Colour+darkGreen = RGB 0 100 0+darkBlue = RGB 0 0 139+violet = RGB 238 130 238+indigo = RGB 75 0 130+darkRed = RGB 139 0 0+darkMagenta = RGB 139 0 139+darkOrange = RGB 255 140 0+orange = RGB 255 165 0+lightPink = RGB 255 182 193+purple = RGB 128 0 128+lightGreen = RGB 144 238 144+mediumPurple = RGB 147 112 219+darkViolet = RGB 148 0 211++gray = RGB 128 128 128+darkGrey = RGB 169 169 169 -- lighter than grey?+darkGray = RGB 169 169 169+lightGray = RGB 211 211 211+silver = RGB 192 192 192+whiteSmoke = RGB 245 245 245++aqua = RGB 0 255 255+teal = RGB 0 128 128+maroon = RGB 128 0 0+olive = RGB 128 128 0+sienna = RGB 160 82 45+brown = RGB 165 42 42+fuchsia = RGB 255 0 255+turquoise = RGB 64 224 208+orangeRed = RGB 255 69 0+gold = RGB 255 215 0+darkSlateGray = RGB 47 79 79
+ src/Common.hs view
@@ -0,0 +1,216 @@+module Common (module Common, module Debug.Trace, module Colors) where++import Colors+import Debug.Trace(trace)+import qualified Data.IntMap as IntMap+import Data.Char(isSpace)+import GHC.Float(formatRealFloat, FFFormat(FFFixed))+import Data.List++import qualified Data.Map as Map++-- | return a list of all cartesian products for a list of lists+-- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]]+products :: [[a]] -> [[a]]+products [] = [[]]+products (xs:xss) = [ x:prod | x <- xs, prod <- products xss]++trees :: Show a => String -> a -> a+trees msg a = trace ("{" ++ msg ++ ":" ++ show a ++ "}") a++foreach :: Monad m => [a] -> (a -> m b) -> m [b]+foreach = flip mapM++foreach_ :: Monad m => [a] -> (a -> m b) -> m ()+foreach_ list fun = do+ mapM fun list+ return ()++ifJust :: Monad m => Maybe a -> (a -> m b) -> m ()+ifJust ma f =+ case ma of+ Nothing -> return ()+ Just a -> do { f a; return () }++internalError :: String -> String -> String -> a++internalError moduleName functionName errorString =+ error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)++parseDouble :: String -> Maybe Double+parseDouble string =+ case reads (commasToDots . trim $ string) of+ ((double, []):_) -> Just double+ _ -> Nothing+ where+ commasToDots = map (\c -> if c == ',' then '.' else c)++trim :: String -> String+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- | A NumberMap maps integers to integers+type NumberMap = IntMap.IntMap Int++-- | A NumberMap can be inverted (keys become values and values become keys)+invertMap :: NumberMap -> NumberMap+invertMap theMap =+ let list = IntMap.toList theMap+ invertedList = map (\(x, y) -> (y, x)) list+ in IntMap.fromList invertedList++-- | commasAnd combines a list of strings to one string by placing+-- commas in between and the word "and" just before the last element+commasAnd :: [String] -> String+commasAnd [] = ""+commasAnd [x] = x+commasAnd [x, y] = x ++ " and " ++ y+commasAnd (x:xs) = x ++ ", " ++ commasAnd xs+++-- TODO: is niceFloat 2 0.0001 = "0.0" correct? (as opposed to "0.00")+-- | niceFloat prints a floating-point value with maximum+-- number of decimals+niceFloat :: Int -> Double -> String+niceFloat nrOfDigits f =+ let s = formatRealFloat FFFixed (Just nrOfDigits) f+ s' = reverse s -- s -- dropWhile (== '0') (reverse s)+ s'' = if head s' == '.' then '0':s' else s'+ in reverse s''++-- | niceFloatFix prints a floating-point value with fixed+-- number of decimals+niceFloatFix :: Int -> Double -> String+niceFloatFix nrOfDigits f =+ let s = formatRealFloat FFFixed (Just nrOfDigits) f+ in if head s == '.' then '0':s else s++-- Compute the average of a list of fractionals, with average [] equal to 0.+average :: Fractional a => [a] -> a+average [] = 0+average xs = (sum xs) / fromIntegral (length xs)++-- | updateList changes the element at the given zero-based index in a list+-- Example: updateList 2 "yes" ["no","maybe","often","always"] ==>+-- ["no","maybe","yes","always"]+updateList :: Int -> a -> [a] -> [a]+updateList i x l = take i l ++ [x] ++ drop (i+1) l++-- | groups splits a list into groups of given length. The+-- last group might be shorter.+-- Example: groups 3 [1..10] ==> [[1,2,3],[4,5,6],[7,8,9],[10]]+groups :: Int -> [a] -> [[a]]+groups _ [] = []+groups n xs = let (col, rest) = splitAt n xs+ in col: groups n rest++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)++-- remove the extension from a file name (or path).+removeExtension :: String -> String+removeExtension filename =+ case break (=='.') $ reverse filename of+ (_ , _ {- dot -}:properName) -> reverse properName+ (_ , []) -> filename++tabDelimited :: [[String]] -> String+tabDelimited = unlines . map (concat . intersperse "\t")++singleton :: a -> [a]+singleton x = [x]++-- | a version of Prelude.lookup that fails when the element is not present in the assoc-list+unsafeLookup :: (Show k, Eq k) => k -> [(k,v)] -> v+unsafeLookup x assocs =+ case lookup x assocs of+ Just v -> v+ Nothing -> internalError "Common" "unsafeLookup" ("element " ++ show x ++ " not in list.")++-- | a version of Prelude.elemIndex that fails when the element is not present in the list+unsafeElemIndex :: (Show a, Eq a) => a -> [a] -> Int+unsafeElemIndex x xs =+ case elemIndex x xs of+ Just i -> i+ Nothing -> internalError "Common" "unsafeElemIndex" ("element " ++ show x ++ " not in list")++-- Approximately equals+(~=) :: Double -> Double -> Bool+(~=) d1 d2 = abs (d1 - d2) < 0.000001++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++thd3 :: (a, b, c) -> c+thd3 (_, _, c) = c++safeIndex :: String -> [a] -> Int -> a+safeIndex msg xs i+ | i >= 0 && i < length xs = xs !! i+ | otherwise = internalError "Common" "safeIndex" msg++-- reorderList [0,2,1] "hoi" ==> "hio"+reorderList :: Show a => [Int] -> [a] -> [a]+reorderList order xs+ | sort order /= [0..length xs-1] =+ internalError "Common" "reorderList" ("order = " ++ show order ++ ", list = " ++ show xs)+ | otherwise =+ [ xs !! i | i <- order ]++infix 6 /\ +infix 7 ><++(/\) :: ( a -> b ) -> ( a -> c ) -> a -> (b,c)+(/\) f1 f2 a = (f1 a, f2 a)++(><) :: ( a -> c ) -> ( b -> d ) -> (a,b) -> (c,d)+(><) f1 f2 (a, b) = (f1 a, f2 b)++diag :: a -> (a,a)+diag a = (a, a)++int2name :: Int -> String+int2name n | n<=0 = error "Unexpected number; a positive number was expected." + | otherwise = aux (n-1)+ where aux m = (if q == 0 then [] else int2name q) ++ [toEnum (r + fromEnum 'a')]+ where (q, r) = m `divMod` 26++takeJust :: String -> Maybe a -> a+takeJust erro (Just res) = res+takeJust erro Nothing = error erro++removeQuotes :: String -> String+removeQuotes ('"':str) = init str+removeQuotes str = str ++spaces2underscores :: String -> String+spaces2underscores = map f + where f ' ' = '_'+ f c = c++indent :: Int -> String -> String+indent n = unlines' . map (replicate n '\t' ++) . lines++-- | Similar to 'unlines' but without an @'\n'@ in the end.+unlines' :: [String] -> String+unlines' = foldr1 (\str1 str2 -> str1 ++ '\n':str2)++infix 9 !+!++(!+!) :: [a] -> [Int] -> [a]+(!+!) l li = map (l !!) li++-- | 'foldl' for compositions+foldlCont :: (a -> b -> a) -> [b] -> a -> a+foldlCont f l init = foldl f init l++-- | Filter repeated elements only, mentioning the number of repetitions.+repeateds :: Ord a => [a] -> [(a, Int)]+repeateds = Map.toList . Map.filter (>1) . Map.fromListWith (+) . map (\x -> (x,1))++-- | Test for repeated elements.+haveRepeateds :: Ord a => [a] -> Bool+haveRepeateds = any ( (/=1) . snd) . repeateds+
+ src/CommonIO.hs view
@@ -0,0 +1,333 @@+module CommonIO where++import Math+import Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey)+import SafetyNet++import Graphics.UI.WX+import Graphics.UI.WXCore+import Data.List(elemIndex)+import System.Directory+import System.IO++ignoreResult :: IO a -> IO ()+ignoreResult action = do { action; return () }++-- | Writes file to disk. If writing fails, an error+-- dialog is shown and False is returned+safeWriteFile :: Window a -> String -> String -> IO Bool+safeWriteFile parentWindow fileName contents =+ do{ let tmpName = fileName ++ ".tmp"++ ; -- try to write to .tmp file+ ; writeOkay <-+ catch+ (do { writeFile tmpName contents+ ; return True+ })+ (\ioExc ->+ do{ errorDialog parentWindow "Save failed"+ ( "Saving " ++ fileName ++ " failed.\n\n"+ ++ "Technical reason: " ++ show ioExc ++ "\n\n"+ ++ "Tip: do you have write permissions and enough disk space?"+ )+ ; return False+ }+ )+ ; if not writeOkay then+ return False+ else+ do{ -- remove old file if it exists and then rename .tmp to the real name+ ; catch (do { exists <- doesFileExist fileName+ ; when exists $ removeFile fileName+ ; renameFile tmpName fileName+ ; return True+ })+ (\ioExc ->+ do{ errorDialog parentWindow "Save failed"+ ( "The file has been saved to " ++ show tmpName ++ "\nbut "+ ++ "renaming it to " ++ show fileName ++ " failed.\n\n"+ ++ "Technical reason: " ++ show ioExc+ )+ ; return False+ }+ )+ }}++strictReadFile :: String -> IO String+strictReadFile fname =+ do{ contents <- readFile fname+ ; seq (length contents) $ return contents -- force reading of entire file+ }++data TextCtrlSize = SingleLine | MultiLine++myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool+ -> IO (Maybe String)+myTextDialog parentWindow size dialogTitle initial selectAll =+ do{ d <- dialog parentWindow [text := dialogTitle]+ ; textInput <- (case size of + SingleLine -> textEntry+ MultiLine -> textCtrl)+ d [ alignment := AlignLeft, text := initial ]+ ; ok <- button d [text := "Ok"]+ ; can <- button d [text := "Cancel", identity := wxID_CANCEL]+ ; buttonSetDefault ok+ ; set d [layout := column 10 [ hfill $ widget textInput+ , floatBottomRight $ row 5 [widget ok, widget can]+ ]+ ]+ ; when (not selectAll) $ do set d [ visible := True ]+ textCtrlSetInsertionPointEnd textInput+ ; showModal d $ \stop ->+ do set ok [on command := safetyNet parentWindow $+ do theText <- get textInput text+ stop (Just theText)]+ set can [on command := safetyNet parentWindow $ stop Nothing]+ }++-- Dialog for selecting a multiple Strings (0 or more)+-- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings+multiSelectionDialog :: Window a -> String -> [String] -> [String]+ -> IO (Maybe [String])+multiSelectionDialog parentWindow dialogTitle strings initialSelection =+ do{ d <- dialog parentWindow+ [ text := dialogTitle+ , resizeable := True+ ]+ ; p <- panel d []+ ; theListBox <- multiListBox p+ [ items := strings+ , selections :=+ [ case maybeIndex of+ Nothing -> internalError "CommonIO" "multiSelectionDialog"+ ( "initial selection " ++ show s+ ++ " can not be found in " ++ show strings )+ Just i -> i+ | s <- initialSelection+ , let maybeIndex = elemIndex s strings+ ]+ ]+ ; selectAll <- button p+ [ text := "Select all"+ , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ]+ ]+ ; selectNone <- button p+ [ text := "Select none"+ , on command := safetyNet parentWindow $ set theListBox [ selections := [] ]+ ]+ ; ok <- button p [text := "Ok"]+ ; can <- button p [text := "Cancel", identity := wxID_CANCEL]+ ; buttonSetDefault ok+ ; set d [ layout := container p $+ column 10 [ vfill $ widget theListBox+ , row 5 [widget selectAll, widget selectNone, widget ok, widget can]+ ]+ , clientSize := sz 300 400+ ]+ ; showModal d $ \stop ->+ do set ok [on command := safetyNet parentWindow $+ do indices <- get theListBox selections+ stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))]+ set can [on command := safetyNet parentWindow $+ stop Nothing]+ }++-- Dialog for selecting a single String+-- Returns Nothing if Cancel was pressed, otherwise it returns the selected string+singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String)+ -> IO (Maybe String)+singleSelectionDialog _ _ [] _ =+ internalError "CommonIO" "singleSelectionDialog" "no strings"+singleSelectionDialog parentWindow dialogTitle strings initialSelection =+ do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ]+ ; p <- panel d []+ ; theListBox <- singleListBox p [ items := strings, selection := 0]+ ; ifJust initialSelection $ \selString ->+ case elemIndex selString strings of+ Nothing -> internalError "CommonIO" "singleSelectionDialog"+ ( "initial selection " ++ show selString+ ++ " can not be found in " ++ show strings )+ Just i -> set theListBox [ selection := i ]+ ; ok <- button p [text := "Ok"]+ ; can <- button p [text := "Cancel", identity := wxID_CANCEL]+ ; buttonSetDefault ok+ ; set d [ layout := container p $+ column 10 [ vfill $ widget theListBox+ , row 5 [widget ok, widget can]+ ]+ , clientSize := sz 300 400+ ]+ ; showModal d $ \stop ->+ do set ok [on command := safetyNet parentWindow $+ do index <- get theListBox selection+ stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))]+ set can [on command := safetyNet parentWindow $+ stop Nothing]+ }++-- | Fill a grid from a list of lists of texts. Each list inside the+-- big list represents a row. Also set the given number or rows and+-- columns to be header: grey background and not editable.+-- This function assumes that the normal spreadsheet-like grid header row+-- and column have been made invisible.+fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO ()+fillGridFromList _ _ _ [] = return ()+fillGridFromList theGrid nrHeaderRows nrHeaderCols list =+ do{ nrOfCols <- gridGetNumberCols theGrid+ ; nrOfRows <- gridGetNumberRows theGrid+ ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $+ internalError "Common" "fillGridFromList" "grid is not big enough"+ ; sequence_ . concat $+ [ [ do{ gridSetCellValue theGrid rowNr colNr txt+ ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols+ ; gridSetCellBackgroundColour theGrid rowNr colNr+ (if isHeaderCell then systemGrey else white)+ ; gridSetReadOnly theGrid rowNr colNr isHeaderCell+ }+ | (txt, colNr) <- zip theRow [0..]+ ]+ | (theRow, rowNr) <- zip list [0..]+ ]+ }++-- | Export some data (a list of lists of strings) to a tab delimited+-- file. The user is asked to choose a location+exportToTabFile :: Window a -> String -> String -> [[String]] -> IO ()+exportToTabFile parentWindow description fileName theData =+ do { mFilename <- fileSaveDialog+ parentWindow+ False -- remember current directory+ True -- overwrite prompt+ ("Export " ++ description)+ [("Tab delimited files",["*.txt"])]+ "" -- directory+ fileName+ ; ifJust mFilename $ \filename ->+ ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData))+ }++getScreenPPI :: IO Size+getScreenPPI =+ do{ dc <- screenDCCreate+ ; s <- dcGetPPI dc+ ; screenDCDelete dc+ ; return s+ }++screenToLogicalPoint :: Size -> Point -> DoublePoint+screenToLogicalPoint ppi p =+ DoublePoint (screenToLogicalX ppi (pointX p))+ (screenToLogicalY ppi (pointY p))++logicalToScreenPoint :: Size -> DoublePoint -> Point+logicalToScreenPoint ppi doublePoint =+ pt (logicalToScreenX ppi (doublePointX doublePoint))+ (logicalToScreenY ppi (doublePointY doublePoint))++screenToLogicalX :: Size -> Int -> Double+screenToLogicalX ppi x =+ fromIntegral x / (fromIntegral (sizeW ppi) / 2.54)++logicalToScreenX :: Size -> Double -> Int+logicalToScreenX ppi x =+ truncate (x * fromIntegral (sizeW ppi) / 2.54)++screenToLogicalY :: Size -> Int -> Double+screenToLogicalY ppi y =+ fromIntegral y / (fromIntegral (sizeH ppi) / 2.54)++logicalToScreenY :: Size -> Double -> Int+logicalToScreenY ppi y =+ truncate (y * fromIntegral (sizeH ppi) / 2.54)++-- Create a grid of which the standard labels (A,B,C... for columns+-- and 1,2,3... for rows) are invisible+mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ())+mkNoLabelGrid thePanel nrOfRows nrOfCols =+ do{ theGrid <- gridCreate thePanel idAny rectNull 0+ ; gridCreateGrid theGrid nrOfRows nrOfCols 0+ ; gridSetColLabelSize theGrid 0+ ; gridSetRowLabelSize theGrid 0+ ; return theGrid+ }++resizeGrid :: Grid () -> Int -> Int -> IO ()+resizeGrid theGrid nrOfRows nrOfCols =+ do{ oldNrOfRows <- gridGetNumberRows theGrid+ ; oldNrOfCols <- gridGetNumberCols theGrid+ ; when (nrOfRows > oldNrOfRows) . ignoreResult $+ gridAppendRows theGrid (nrOfRows - oldNrOfRows) False+ ; when (nrOfRows < oldNrOfRows) . ignoreResult $+ gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False+ ; when (nrOfCols > oldNrOfCols) . ignoreResult $+ gridAppendCols theGrid (nrOfCols - oldNrOfCols) False+ ; when (nrOfCols < oldNrOfCols) . ignoreResult $+ gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False+ }++-- | Get the position of a frame, if the frame is minimized or maximized+-- it is restored to its normal size first. Otherwise, you get+-- (-32000, -32000) for a minimized window :-)+safeGetPosition :: Frame a -> IO (Int, Int)+safeGetPosition f =+ do{ isMax <- frameIsMaximized f+ ; isMin <- frameIsIconized f+ ; when (isMax || isMin) $ frameRestore f+ ; p <- get f position+ ; return (pointX p, pointY p)+ }++-- Show a dialog with a grid and a save button+gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]]+ -> IO () -> IO ()+gridDialogWithSave parentWindow title maybeNote matrixContents saveAction =+ do{+ -- Create dialog and panel+ ; theDialog <- dialog parentWindow+ [ text := title+ , resizeable := True+ ]+ ; p <- panel theDialog []++ -- Create and fill grid+ ; theGrid <- mkNoLabelGrid p height width+ ; gridEnableEditing theGrid False+ ; fillGridFromList theGrid 0 0 matrixContents+ ; gridAutoSizeColumns theGrid False++ -- File menu+ ; saveButton <- button p+ [ text := "Save as..."+ , on command := safetyNet parentWindow $ saveAction+ ]++ -- Dialog layout+ ; set theDialog+ [ layout := minsize (sz 600 400) $ column 5+ ( case maybeNote of+ Just note -> [ hfill $ label note ]+ Nothing -> []+ ++ [ container p $+ column 5 [ fill $ widget theGrid+ , row 0 [ widget saveButton, glue ]+ ]+ ]+ )+ , visible := True+ ]+ }+ where+ width = maximum . map length $ matrixContents+ height = length matrixContents+++-- | Using bootstrapUI, a record containing all widgets and variables can be created+-- at the end of the create function, but still referred to before creation+-- NOTE: widgets should not be referred to in a strict way because this will+-- cause a loop+bootstrapUI :: (uistate -> IO uistate) -> IO ()+bootstrapUI fIO =+ do { fixIO fIO+ ; return ()+ }
+ src/CommonUI.hs view
@@ -0,0 +1,1220 @@+{-# OPTIONS -cpp #-}+module CommonUI where++import GUIEvents+import SafetyNet+import State+import StateUtil+import Network+import NetworkView+import DocumentFile+import Document+import INRule+import INRules+import Common+import CommonIO+import qualified PersistentDocument as PD+import qualified PDDefaults as PD+import Palette+import Shape+import Ports+import Math+import InfoKind+import Constants+import Text.XML.HaXml.XmlContent (XmlContent)+import Text.Parse as Parse+import INChecks+import SpecialSymbols++import Graphics.UI.WX hiding (Child, upKey, downKey, swap)+import Graphics.UI.WXCore hiding (Document, Palette)++import Data.Maybe+import Data.List+import qualified Data.Map as Map+++noImage = -1 :: Int++-- | Prints a document in a none XMl format+printy :: (InfoKind n g, InfoKind e g, Show g) => Document.Document g n e -> IO ()+printy doc = + do let network = getNetwork doc+ rules = getRules doc+ mostraNodos network+ putStrLn "+++++++++++++++++++++++++++++++"+ mapM_ f rules+ where mostraNodos network = print $ map Network.getName $ getNodes network+ f rule = do putStrLn $ INRule.getName rule+ putStrLn "lhs"+ mostraNodos $ getLHS rule+ putStrLn "rhs"+ mostraNodos $ getRHS rule+ print $ INRule.getMapping rule+ putStrLn "-----------------------------------"++paintHandler :: (InfoKind n g, InfoKind e g) => + State g n e -> DC () -> ActiveCanvas -> IO ()+paintHandler state dc canvas =+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; dp <- getDisplayOptions state+ ; let network = selectNetwork doc canvas+ selection = getSelection doc+ palette = getPalette doc+ selection' = selection `filterSelectionTo` canvas+ ; mapp <- case canvas of+ Net -> return []+ LHS rule -> maybe (fail $ rule ++ " not found.") + (return . map fst . getMapping) + . findRule rule $ getRules doc + RHS rule -> maybe (fail $ rule ++ " not found.") + (return . map snd . getMapping) + . findRule rule $ getRules doc ++ ; drawCanvas network palette selection' mapp dc dp+ }+ where filterSelectionTo :: Document.Selection -> ActiveCanvas + -> Document.Selection+ filterSelectionTo selection canvas =+ case selection of+ NodeSelection canv _ _ | canv == canvas -> selection+ EdgeSelection canv _ | canv == canvas -> selection+ ViaSelection canv _ _ | canv == canvas -> selection+ MultipleSelection canv _ _ _ | canv == canvas -> selection+ _ -> NoSelection +++chooseNetwork :: State g n e -> IO (Network g n e)+chooseNetwork state = + do canvas <- getActiveCanvas state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ case canvas of+ Net -> return $ getNetwork doc+ LHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return + $ getLHS `fromRule` rule $ getRules doc+ RHS rule -> maybe (fail $ "Invalid rule name: " ++ rule) return + $ getRHS `fromRule` rule $ getRules doc++mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>+ EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO ()+mouseEvent eventMouse canvas theFrame state = case eventMouse of+ MouseLeftDown mousePoint mods+ | shiftDown mods -> leftMouseDownWithShift mousePoint state+ | metaDown mods || controlDown mods -> leftMouseDownWithMeta mousePoint state+ | otherwise -> mouseDown True mousePoint theFrame state+ MouseRightDown mousePoint _ ->+ mouseDown False mousePoint theFrame state+ MouseLeftDrag mousePoint _ ->+ leftMouseDrag mousePoint canvas state+ MouseLeftUp mousePoint _ ->+ leftMouseUp mousePoint state+ _ ->+ return ()++keyboardEvent :: (InfoKind n g, InfoKind e g) =>+ Frame () -> State g n e -> EventKey -> IO ()+keyboardEvent theFrame state (EventKey theKey _ _) =+ case theKey of+ KeyDelete -> deleteKey state+ KeyBack -> backspaceKey state+ KeyF2 -> f2Key theFrame state+ KeyChar 'r' -> pressRKey theFrame state+ KeyChar 'i' -> pressIKey theFrame state+ KeyUp -> upKey state+ KeyDown -> downKey state+ _ -> propagateEvent++closeDocAndThen :: State g n e -> IO () -> IO ()+closeDocAndThen state action =+ do{ pDoc <- getDocument state+ ; continue <- PD.isClosingOkay pDoc+ ; when continue $ action+ }++setInterfacePalette :: (InfoKind n g) => n -> State g n e -> IO ()+setInterfacePalette n state =+ do pDoc <- getDocument state++ let interfacePal = Palette [interfaceSymbol]+ -- set the initial palette only with interface symbol + PD.superficialUpdateDocument (setPalette interfacePal) pDoc+ setCurrentShape (fst interfaceSymbol) state++ buildVisiblePalette state+++newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO ()+newItem state g n e =+ closeDocAndThen state $+ do{ pDoc <- getDocument state+ ; PD.resetDocument Nothing (Document.empty g n e) pDoc+ ; initializeRules state g n e + ; reAddRules2Tree state+ ; setInterfacePalette n state+ ; repaintAll state+ }++openItem :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ Frame () -> State g n e -> IO ()+openItem theFrame state =+ do{ mbfname <- fileOpenDialog+ theFrame+ False -- change current directory+ True -- allowReadOnly+ "Open File"+ extensions+ "" "" -- no default directory or filename+ ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame)+ }++-- Third argument: Nothing means exceptions are ignored (used in Configuration)+-- Just f means exceptions are shown in a dialog on top of frame f+openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ String -> State g n e -> Maybe (Frame ()) -> IO ()+openNetworkFile fname state exceptionsFrame =+ closeDocAndThen state $+ flip catch+ (\exc -> case exceptionsFrame of+ Nothing -> return ()+ Just f -> errorDialog f "Open network"+ ( "Error while opening '" ++ fname ++ "'. \n\n"+ ++ "Reason: " ++ show exc)+ ) $+ do{ contents <- strictReadFile fname+ ; let errorOrDocument = DocumentFile.fromString contents+ ; case errorOrDocument of {+ Left err -> ioError (userError err);+ Right (doc, warnings, oldFormat) ->+ do{ + ; pDoc <- getDocument state+ ; PD.resetDocument (if null warnings then Just fname else Nothing)+ doc pDoc+ ; applyCanvasSize state+ ; when (not (null warnings)) $+ case exceptionsFrame of+ Nothing -> return ()+ Just f ->+ do{ errorDialog f "File read warnings"+ ( "Warnings while reading file " ++ show fname ++ ":\n\n"+ ++ unlines ( map ("* " ++) (take 10 warnings)+ ++ if length warnings > 10 then ["..."] else []+ )+ ++ unlines+ [ ""+ , "Most likely you are reading a file that is created by a newer version of " ++ toolName ++ ". If you save this file with"+ , "this version of " ++ toolName ++ " information may be lost. For safety the file name is set to \"untitled\" so that you do"+ , "not accidentally overwrite the file"+ ]+ )+ ; PD.setFileName pDoc Nothing+ }+ ; when oldFormat $+ do{ case exceptionsFrame of+ Nothing -> return ()+ Just f ->+ errorDialog f "File read warning" $+ unlines+ [ "The file you opened has the old " ++ toolName ++ " file format which will become obsolete in newer versions of " ++ toolName ++ "."+ , "When you save this network, the new file format will be used. To encourage you to do so the network has"+ , "been marked as \"modified\"."+ ]+ ; PD.setDirty pDoc True+ }+ ; -- Redraw+ ; buildVisiblePalette state+ ; reAddRules2Tree state + ; repaintAll state+ }}}++openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO ()+openPalette theFrame state =+ do{ mbfname <- fileOpenDialog+ theFrame+ False -- change current directory+ True -- allowReadOnly+ "Open File"+ paletteExtensions + "" "" -- no default directory or filename+ ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame)+ }++-- Third argument: Nothing means exceptions are ignored (used in Configuration)+-- Just f means exceptions are shown in a dialog on top of frame f+openPaletteFile :: (InfoKind n g, Parse n) =>+ String -> State g n e -> Maybe (Frame ()) -> IO ()+openPaletteFile fname state exceptionsFrame =+ flip catch+ (\exc -> case exceptionsFrame of+ Nothing -> return ()+ Just f -> errorDialog f "Open shape palette"+ ( "Error while opening '" ++ fname ++ "'. \n\n"+ ++ "Reason: " ++ show exc)+ ) $+ do{ contents <- readFile fname+ ; case fst (runParser parse contents) of {+ Left msg -> ioError (userError ("Cannot parse shape palette file: "+ ++fname++"\n\t"++msg));+ Right p -> do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; let newPalette = removeQuotesFromNames p+ oldPalette = getPalette doc + newNames = shapesNames newPalette+ oldNames = shapesNames oldPalette + + ; let cont = newNames `union` oldNames == newNames+ ; yes <- if cont + then return True+ else + case exceptionsFrame of + Nothing -> return False+ Just f -> confirmDialog f + "Conflict with palettes" + ("The old palette has names that are not defined in the one that you intend to load.\nThis can make the system inconsistent.\n\nDo you want to load the new palette anyway ?") False+ ; when (cont || yes) $ + do PD.updateDocument "change palette"+ (setPalette newPalette)+ pDoc+ -- the shape name of the first palette's element is chosen+ -- as the default one+ setCurrentShape (fst . head . shapes $ newPalette) state++ buildVisiblePalette state+ }+ }}+ where remQuot = init . tail+ removeQuotesFromNames = Palette . map (\(a,b) -> (remQuot a, rem1 b) ) . shapes + rem1 (shape, mPorts, info) = (shape, map rem3 mPorts , info)+ rem3 (str, dpoint) = (remQuot str, dpoint)++savePalette :: Show n => Frame () -> State g n e -> IO ()+savePalette theFrame state =+ do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ mfname <- PD.defaultSaveAsDialog theFrame paletteExtensions Nothing+ case mfname of+ Just fname -> do safeWriteFile theFrame fname . show $ getPalette doc+ return ()+ Nothing -> return ()++-- | Get the canvas size from the network and change the size of+-- the widget accordingly+applyCanvasSize :: State g n e -> IO ()+applyCanvasSize state =+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; let network = getNetwork doc+ (width, height) = getCanvasSize network+ ; canvas <- getCanvas state+ ; ppi <- getScreenPPI+ ; set canvas [ virtualSize := sz (logicalToScreenX ppi width)+ (logicalToScreenY ppi height) ]+ }+++saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ Frame () -> String -> Document.Document g n e -> IO Bool+saveToDisk theFrame fileName doc =+ safeWriteFile theFrame fileName (DocumentFile.toString doc)++exit :: State g n e -> IO ()+exit state =+ closeDocAndThen state $ propagateEvent++-- Code for build the Visible Palette++buildVisiblePalette :: InfoKind n g => State g n e -> IO ()+buildVisiblePalette state =+ do{ pDoc2 <- getDocument state+ ; pp <- getPalettePanel state+ ; doc <- PD.getDocument pDoc2+ ; let palette = getPalette doc++ -- its necessary to delete the old elements in the panel+ ; windowChildren pp >>= mapM objectDelete+ + ; reallyBuildVisiblePalette palette pp state setCurrentShape+ }++reallyBuildVisiblePalette :: InfoKind n g => + Palette.Palette n -> Panel () -> State g n e+ -> (String -> State g n e -> IO ()) -> IO ()+reallyBuildVisiblePalette palette panel state action =+ do list <- mapM (drawNodeButton panel state action) . shapes $ palette+ let table = list2Table 2 list ++ set panel [layout := +#if !defined(__APPLE__)+ boxed "Symbol palette" +#endif+ (grid 4 4 table) ]+++drawNodeButton :: InfoKind n g => Window w -> State g n e -> (String -> State g n e -> IO ()) + -> (String, (Shape, Ports, Maybe n)) -> IO Layout+drawNodeButton w state action (name, (shape, ports, _info)) = + do{ frame <- getNetworkFrame state+ ; node <- button w [ text := name+ -- , clientSize := sz 50 50 -- due to a wxHaskell problem forcing the size don't works+ , on command := action name state+ , on mouse := \ev -> safetyNet frame $ mouseSymbol ev name action state+ , tooltip := name+ , bgcolor := white + , on paint := \dc r -> safetyNet frame $ + do { logicalDraw ppi dc (center r) shape []+ ; drawPorts ppi dc (center r) ports []+ }+ -- , checked := True+ ]+ ; return (widget node)+ }+ where factor f (DoublePoint x y) = DoublePoint (x/f) (y/f)+ ppi = (sz 40 40) -- (rectSize r) this is the correct code if+ center r = factor 14.0 $ intPointToDoublePoint $ rectCentralPoint r++mouseSymbol :: InfoKind n g => EventMouse -> String -> (String -> State g n e -> IO ()) -> State g n e -> IO ()+mouseSymbol mouseEV name action state =+ case mouseEV of+ MouseLeftUp _ _ -> action name state+ MouseRightUp _ _ -> removeSymbolUI name state+ _ -> return ()++-- | Transforms a list in a table of n columns+list2Table :: Int -> [a] -> [[a]]+list2Table n l | null l = []+ | otherwise = a : list2Table n b + where (a,b) = splitAt n l++createNewAgentItem :: InfoKind n g => State g n e -> IO ()+createNewAgentItem state = + do mRes <- createAgentByNameDialog state+ case mRes of+ Just (agentName, agentShape, ports) -> + do{ pDoc <- getDocument state+ ; let newElem = (agentName, (agentShape, ports, Nothing))+ ; PD.updateDocument "change palette"+ (\doc -> setPalette (Palette . (++ [newElem]) . shapes . getPalette $ doc) + doc)+ pDoc+ + ; setCurrentShape (agentName) state++ ; buildVisiblePalette state+ }+ _ -> return ()++removeSymbolUI :: (InfoKind n g) => String -> State g n e -> IO ()+removeSymbolUI name state =+ when (name /= "interface") $+ do contextMenu <- menuPane []+ menuItem contextMenu+ [ text := "Remove symbol"+ , on command := removeSymbol name state+ ]+ theFrame <- getNetworkFrame state+ pointWithinWindow <- windowGetMousePosition theFrame+ menuPopup contextMenu pointWithinWindow theFrame+ objectDelete contextMenu++-- | Removes a symbol if it is not used or else don't remove and list its occurrences.+removeSymbol :: (InfoKind n g) => String -> State g n e -> IO ()+removeSymbol name state =+ do theFrame <- getNetworkFrame state+ if name == "interface"+ then warningDialog theFrame "Deletion forbidden" "Interface symbol is a special one that can't be deleted."+ else+ do+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc++ let newpal = deleteShape name $ getPalette doc+ symbs = map fst . shapes $ newpal+ errors = undefinedAgents symbs doc+ if Map.null errors+ then do -- symbol can be safely removed+ remove <- confirmDialog theFrame "Symbol deletion"+ ("Symbol \"" ++ name +++ "\" can be safely removed.\nAre you sure you want to delete it?")+ False+ if remove+ then do PD.updateDocument ("Symbol " ++ name ++ " removed") (setPalette newpal) pDoc+ buildVisiblePalette state+ else return ()++ else -- there are occurrences of symbol; list them+ errorDialog theFrame "Deletion forbidden" $+ "Symbol \"" ++ name +++ "\" can't be deleted because there are the following occurrences of it in the IN system:\n"+ ++ (unlines . map show $ Map.keys errors)++-- | List the rules on a one level tree. +addRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => + TreeCtrl a -> TreeItem -> State g n e -> IO ()+addRules2Tree tree item state = + do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ + treeCtrlDeleteChildren tree item+ let rNames = rulesNames $ getRules doc + mapM_ addItemRule rNames ++ -- choose the last rule as the active (displayed) one+ rule <- treeCtrlGetLastChild tree item+ ruleName <- treeCtrlGetItemText tree rule+ setActiveRule ruleName state+ treeCtrlSelectItem tree rule+ where addItemRule ruleName = + treeCtrlAppendItem tree item ruleName noImage noImage objectNull ++-- | Eliminates old rules and add the newer ones.+reAddRules2Tree :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => + State g n e -> IO ()+reAddRules2Tree state =+ do tree <- getTree state+ root <- treeCtrlGetRootItem tree+ addRules2Tree tree root state++onTreeEvent :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => + TreeCtrl a -> State g n e -> g -> n -> e -> EventTree -> IO ()+onTreeEvent tree state g n e event = + case event of + TreeSelChanged item olditem | treeItemIsOk item+ -> do wxcBeginBusyCursor+ ruleName <- treeCtrlGetItemText tree item+ when (ruleName /= "Rules") $+ do setActiveRule ruleName state+ repaintAll state+ wxcEndBusyCursor+ propagateEvent+ TreeBeginLabelEdit item str action + | str == "Rules" -> action -- prevents the root from be editable+ TreeEndLabelEdit item new wasCanceled veto | not wasCanceled -> + do -- change rule name+ old <- treeCtrlGetItemText tree item+ + when (new /= old) $+ do pDoc <- getDocument state+ frame <- getNetworkFrame state+ doc <- PD.getDocument pDoc+ let rNames = rulesNames $ getRules doc+ if new `elem` rNames+ then do veto+ warningDialog frame "Warning" + $ "Already exists one rule with name \"" ++ new + ++ "\".\n Please choose a different identifier."+ else do PD.updateDocument "change rule name" + (updateRules + $ updateRule old + $ INRule.setName new) pDoc+ setActiveRule new state+ propagateEvent+ TreeItemRightClick item -> + do ruleName <- treeCtrlGetItemText tree item+ contextMenu <- menuPane []+ theFrame <- getNetworkFrame state ++ if (ruleName == "Rules") -- means right click on root item+ then + do menuItem contextMenu + [ text := "Add new rule"+ , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e+ ] + menuItem contextMenu + [ text := "Create new Interaction Net rule"+ , on command := safetyNet theFrame $ createRuleItem theFrame state g n e+ ]+ else + do menuItem contextMenu + [ text := "Rename rule" + , on command := treeCtrlEditLabel tree item+ ]+ menuItem contextMenu + [ text := "Remove rule"+ , on command := do safetyNet theFrame + $ removeRuleItem state ruleName item+ propagateEvent+ ]++ propagateEvent+ pointWithinWindow <- windowGetMousePosition theFrame+ menuPopup contextMenu pointWithinWindow theFrame+ objectDelete contextMenu+ _+ -> propagateEvent++-- | Adds a new rule setting it with a new name.+addNewRuleItem :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => + Bool -> State g n e -> INRule g n e -> IO ()+addNewRuleItem genNewName state newRule = + do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ + let newName = if genNewName then (addNew 1 . rulesNames $ getRules doc) else (INRule.getName newRule)++ PD.updateDocument ("add rule <<" ++ newName ++ ">>")+ (updateRules $ addNewRule $ (if genNewName then INRule.setName newName else id) $ newRule ) pDoc++ tree <- getTree state+ root <- treeCtrlGetRootItem tree+ item <- treeCtrlAppendItem tree root newName noImage noImage objectNull+ treeCtrlSelectItem tree item+ where addNew :: Int -> [String] -> String+ addNew i rules | newName `elem` rules = addNew (i+1) rules+ | otherwise = newName+ where newName = "Rule " ++ show i +updateTreeSelection :: State g n e -> IO ()+updateTreeSelection state =+ do tree <- getTree state+ root <- treeCtrlGetRootItem tree+ selItem <- treeCtrlGetLastChild tree root+ treeCtrlSelectItem tree selItem++removeRuleItem :: (InfoKind n g, InfoKind e g) => + State g n e -> String -> TreeItem -> IO ()+removeRuleItem state ruleName item = + do frame <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc++ if (1 == ) . length . rulesNames $ getRules doc + then warningDialog frame "Removal forbidden" + "You cannot remove the rule because it is the last one."+ else do tree <- getTree state+ delete <- confirmDialog frame "Rule deletion" msg yesDefault+ + when (delete) $ + do treeCtrlDelete tree item + updateTreeSelection state ++ PD.updateDocument ("remove rule " ++ ruleName) + (updateRules $ removeRule ruleName) pDoc+ + where yesDefault = False+ msg = "Are you sure you want to delete rule \"" ++ ruleName ++ "\" ?"++-- | If there are none rules it creates a empty one.+initializeRules :: (InfoKind.InfoKind n g, InfoKind.InfoKind e g) => + State g n e -> g -> n -> e -> IO ()+initializeRules state g n e = + do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ let rNames = rulesNames $ getRules doc++ if (null rNames) + then+ do -- adds an initial rule+ PD.superficialUpdateDocument + (updateRules $ addNewEmptyRule "Rule 1" g n e) pDoc+ setActiveRule "Rule 1" state+ else setActiveRule (head rNames) state ++lhs2rhsItem :: Bool -> State g n e -> IO ()+lhs2rhsItem everything state = + do pDoc <- getDocument state+ rule <- getActiveRule state+ theFrame <- getNetworkFrame state+ doc <- PD.getDocument pDoc+ let rhs = selectNetwork doc $ RHS rule+ + copy <- if isEmpty rhs+ then return True+ else proceedDialog theFrame "Non empty RHS" $ + "The RHS side of the rule is not empty.\n" ++ + "Copying the LHS will make you loosing it.\n" +++ "Do you want to proceed ?"+ when copy $ + do if everything + then PD.updateDocument ("copy of LHS to RHS on rule " ++ rule) + (updateRules $ updateRule rule $ copyLHS2RHS) pDoc+ else PD.updateDocument ("copy of LHS interface to RHS on rule " ++ rule) + (updateRules $ updateRule rule $ copyLHSInterface2RHS) pDoc+ repaintAll state+ setActiveCanvas (RHS rule) state++data CopyLHS2RHS = Everything | JustInterface | DontCopy | DefaultRule deriving (Show)++-- | Create a dialog where the user have to choose two symbols. +-- An interaction net rule, whose left hand side is the active pair +-- of those two agents, will then be created. +-- A new name is created for this rule.+createRuleItem :: (InfoKind n g, InfoKind e g) => + Frame () -> State g n e -> g -> n -> e -> IO ()+createRuleItem frame state g n e = + do + maybeRes <- chooseAgentsDialog state+ when (isJust maybeRes) $+ do{ + ; pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ;let palette = getPalette doc+ ;let ;(agent1, agent2, copyOption) = fromJust maybeRes+ ;copy = case copyOption of + Everything -> copyLHS2RHS + JustInterface -> copyLHSInterface2RHS + DontCopy -> id+ DefaultRule -> defaultRuleSelector (agent1,agent2) state g n e palette + ; (rule,nNr1,nNr2) <- createRuleWizard g n e palette agent1 agent2+ ; addNewRuleItem False state $ copy rule+ }++-- An interaction net rule, whose left hand side is the active pair+-- of the two given agents, will be created.+-- A new name is created for this rule.+-- Empty RHS.+createRuleWizard :: (InfoKind n g, InfoKind e g) =>+ g -> n -> e -> Palette n+ -> String -> String -> IO (INRule g n e, NodeNr, NodeNr)+createRuleWizard g n e palette agent1 agent2 =+ do{+ ; let+ (nNr1, lhs1) = addNode agent1 palette + $ Network.empty g n e+ (nNr2, lhs2) = addNode agent2 palette lhs1+ + ; (pP1:ports1) <- getPorts' agent1 palette+ ; (pP2:ports2) <- getPorts' agent2 palette++ -- edge connecting principal ports+ ; let lhs3 = addEdge palette nNr1 (fst pP1) nNr2 (fst pP2) lhs2+ + (pos1, pos2) = givePositions pP1 pP2 -- (DoublePoint 2.0 2.0, DoublePoint 6.0 3.0) -- ??+ lhs4 = setNodePosition nNr1 pos1 + . setNodePosition nNr2 pos2 $ lhs3++ -- adding as many interface nodes as needed+ (nrs1, lhs5) = addNodes (fst interfaceSymbol) palette (length ports1) lhs4+ (nrs2, lhs6) = addNodes (fst interfaceSymbol) palette (length ports2) lhs5++ ; interPort <- getInterfacePort palette+ + -- choose interface agents better positions; up or down+ ; let (ups1, downs1) = (map snd >< map snd ) . partition sep $ zip ports1 nrs1+ (ups2, downs2) = (map snd >< map snd ) . partition sep $ zip ports2 nrs2+ orderConcat = chooseOrder pos1 pos2+ + -- add edges between not principal ports in agents to interface nodes and set their positions + lhs7 = rowNodes (DoublePoint 0.5 5.5) (orderConcat downs1 downs2)+ . rowNodes (DoublePoint 0.5 0.5) (orderConcat ups1 ups2)+ . addEdges palette -- edges agent2 to interface+ [((nNr2, fst p'), (n', fst interPort)) | p' <- ports2 | n' <- nrs2]+ . addEdges palette -- edges agent1 to interface+ [((nNr1, fst p'), (n', fst interPort)) | p' <- ports1 | n' <- nrs1] $ lhs6+ ; let rhs = Network.empty g n e+ mapping = [] + ; return (construct (agent1 ++ "_" ++ agent2) lhs7 rhs mapping, nNr1,nNr2)+ }+ where getPorts' = getSymbolPorts++ getInterfacePort :: Palette.Palette n -> IO Port+ getInterfacePort palette = + do ps <- getPorts' "interface" palette+ case ps of + [port] -> return port+ _ -> fail "Interface agent with more than one port."+ givePositions :: Port -> Port -> (DoublePoint, DoublePoint)+ givePositions port1 port2 = g (portZone port1) (portZone port2)+ where g Ztop Ztop = lineH+ g Zbottom Zbottom = lineH+ g Zleft Zleft = lineV+ g Zright Zright = lineV+ g Ztop Zbottom = invert lineV+ g Zbottom Ztop = lineV+ g Zleft Zright = invert lineH+ g Zright Zleft = lineH+ g Ztop Zleft = invert lineI+ g Ztop Zright = invert lineD+ g Zbottom Zleft = lineD+ g Zbottom Zright = lineI+ g Zleft Ztop = lineI+ g Zleft Zbottom = invert lineD+ g Zright Ztop = lineD+ g Zright Zbottom = invert lineI+ + c1 = 2.0+ c2 = 4.0 + p1 = DoublePoint c1 c1+ p2 = DoublePoint c2 c1+ p3 = DoublePoint c1 c2+ p4 = DoublePoint c2 c2+ lineH = (p1, p2)+ lineV = (p1, p3)+ lineD = (p1, p4)+ lineI = (p2, p3)+ invert = swap++ sep :: (Port, NodeNr) -> Bool+ sep (port, _) = isUp port+ chooseOrder pos1 pos2 = if doublePointX pos1 <= doublePointX pos2+ then (++)+ else flip (++)++getSymbolPorts :: String -> Palette.Palette n -> IO Ports+getSymbolPorts shape (Palette palette) =+ case Data.List.lookup shape palette of+ Nothing -> fail $ shape ++ " agent is missing."+ Just e -> case snd3 e of+ [] -> fail $ shape ++ " agent without port."+ ps -> return ps++-- | For a list of nodes placed at the same position, change their positions to form a row.+rowNodes :: DoublePoint -> [NodeNr] -> Network g n e -> Network g n e+rowNodes startingPoint nodes net = snd $ foldl gene (startingPoint, net) nodes+gene :: (DoublePoint, Network g n e) -> NodeNr -> (DoublePoint, Network g n e)+gene (actual, oldNet) nNr = (translate actual diff, setNodePosition nNr actual oldNet)+diff = DoublePoint 1.0 0.0+++++defaultRuleSelector :: (InfoKind n g, InfoKind e g) => (String,String) -> State g n e-> g ->n -> e -> + Palette.Palette n -> INRule g n e -> INRule g n e+defaultRuleSelector (a1,a2) state g n e pal rule = case a2 of+ "copy" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal+ "duplicator" -> copyORduplicatorDefaultRule (a1,a2) rule state g n e pal+ "Erase" -> eraseDefaultRule a1 rule state g n e pal+ _ -> rule++------------------------------------------------------------------------------------------------------------------------++eraseDefaultRule :: (InfoKind n g, InfoKind e g) => String ->INRule g n e -> State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)+eraseDefaultRule a1 rule state g n e palette = + let ;newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []+ ;rhs = getRHS newRule + ;inter = getNodeAssocs rhs+ ;(erasers, rhs1) = addNodes "Erase" palette (length inter) rhs+ ;rhs2 = rowNodes (DoublePoint 1.0 1.0) erasers rhs1+ ;rhs3 = addEdges palette (mix (map fst inter) erasers) rhs2+ in (construct ("T:Erase_"++a1) lhs rhs3 (getMapping newRule))+ + where+ mix [] [] = []+ mix (x:y ) (a:b) = [((x, "interface"),(a, "down")) ]++ mix y b+ mix _ _ = []+ ;lhs = getLHS rule++++++copyORduplicatorDefaultRule :: (InfoKind n g, InfoKind e g) => (String,String) -> INRule g n e ->+ State g n e -> g -> n -> e -> Palette.Palette n -> (INRule g n e)+copyORduplicatorDefaultRule (a1,a2) rule state g n e palette = let+ newRule = copyLHSInterface2RHS $ construct "" lhs (Network.empty g n e) []+ rhs = getRHS newRule+ inter = getNodeAssocs rhs+ (alphas, rhs1) = addNodes a1 palette 2 rhs+ (spas,rhs2) = addNodes a2 palette ((\x -> x-1) . length . snd3 . takeJust "Undefined symbol" $ getSymbol a1 palette) rhs1+ rhs3 = rowNodes (DoublePoint 1.0 4.0) spas $ (rowNodes (DoublePoint 1.0 2.0) alphas rhs2)+ (copyI,alphaI) = splitAt ((length inter)-2) inter+ rhs4 = makeInterfaceConection (map fst alphaI) alphas $ makeInterfaceConection (map fst (reverse copyI)) spas rhs3+ newC :: [((NodeNr, PortName), (NodeNr, PortName))]+ newC = newConections $ makeConnection alphas spas rhs4+ rhs5 = addEdges palette newC rhs4+ in (construct ('T':':':a2++'_':a1) lhs rhs5 (getMapping newRule))+ where ;lhs = getLHS rule+-- ;makeInterfaceConection :: [NodeNr] -> [NodeNr] -> Network g n e -> Network g n e+ ;makeInterfaceConection inter node ne = let pp_i = getInterfaceList inter ne+ pp_n = getInterfaceList node ne+ in addEdges palette (zip (zip inter pp_i) (zip node pp_n)) ne+ ;getInterfaceList nodes ne = map (const "interface") nodes+-- ; getJustPorts :: Network g n e -> NodeNr -> [PortName]+ ; getJustPorts ne y = map fst . fromJust $ getPorts palette ne y++-- ;makeConnection :: [NodeNr] -> [NodeNr] -> Network g n e ->([((NodeNr,PortName),(Int,Int))] , [((NodeNr,PortName),(Int,Int))])+ ;makeConnection alphs sps ne = let+ ;alp_p :: [[PortName]]+ ;alp_p = map (reverse . drop 1 . getJustPorts ne ) alphs+ ;alp_p_i = map (zip [1..] ) alp_p+ ;alp_Nr_p = zip [1..] alp_p_i+ ;alp_fin = zip alphs alp_Nr_p+ ;sps_p = map (drop 1 . getJustPorts ne) sps+ ;sps_p_i = map (zip [1..] ) sps_p+ ;sps_Nr_p = zip [1..] sps_p_i+ ;sps_fin = zip sps sps_Nr_p+ in (foldr (++) [] $ map f alp_fin , foldr (++) [] $ map f sps_fin)+ ;f :: (Int,(Int,([(Int,PortName)]))) -> [((NodeNr,PortName),(Int,Int))]+ ;f (_,(_ ,([]))) = [] + ;f(nodeNr,(node_i,((port_i,port) : l ))) = [((nodeNr,port),(node_i,port_i))] ++ f (nodeNr,(node_i,( l )))+getOther :: [((NodeNr,PortName),(Int,Int))] -> (Int,Int) -> (NodeNr,PortName)+getOther (((nr,p),(ni,pi)) :l) (a,b) | (b == ni) && (a==pi) = (nr,p)+ | otherwise = getOther l (a,b)+newConections :: ([((NodeNr,PortName),(Int,Int))],[((NodeNr,PortName),(Int,Int))]) ->[((NodeNr,PortName),(NodeNr,PortName))]+newConections ([],_) = []+newConections ((((nr,p),(ni,pi)) :l), ll) = [((nr,p), getOther ll (ni,pi) ) ] ++ (newConections (l,ll))+++chooseAgentsDialog :: InfoKind n g => State g n e + -> IO ( Maybe (String, String, CopyLHS2RHS))+chooseAgentsDialog state = + do theFrame <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ + -- palette without interface symbol+ let pal = filter ( (/= fst interfaceSymbol).fst )+ . shapes $ getPalette doc++ if null pal + then + do warningDialog theFrame "No symbols" "There are no symbols other than interface one.\nAdd symbol first."+ return Nothing+ else + do let palette = Palette pal+ -- no button was pressed+ setShape1 Nothing state+ setShape2 Nothing state++ -- create Dialog + dia <- dialog theFrame [ text := "Rule creation wizard"]+ p <- panel dia []+ p1 <- panel p []+ p2 <- panel p []+ ;p3 <- panel p2 []+ + ok <- button p [ text := "Ok"+ , enabled := False + ]+ setOkButton ok state ++ let rinfo = [ ("all nodes", Everything)+ , ( "just interface nodes", JustInterface)+ , ("nothing", DontCopy) + , ("Rule template",DefaultRule)+ ]+ (rlabels, rdata) = unzip rinfo+ r1 <- radioBox p Vertical rlabels + [ text := "What to copy automatically from LHS to RHS ?"+ , selection := 1 ++ ]++ ca <- button p [ text := "Cancel" ]++ ;set r1 [ on select ::= logSelect pal p2 state (onClick r1 setJustShape2)] +++ reallyBuildVisiblePalette palette p1 state $ onClick r1 setJustShape1 + reallyBuildVisiblePalette palette p2 state $ onClick r1 setJustShape2+ ++ set dia [ layout := container p $ + margin 10 $ + column 5 [ label "Choose one symbol in each palette."+ , widget p1+ , hrule 350+ , widget p2+ , widget r1+ , row 5 [widget ok, widget ca]+ ]+ ]+ ++ showModal dia $ \stop -> + do set ok [on command := + do mAgent1 <- getShape1 state+ mAgent2 <- getShape2 state+ i <- get r1 selection+ let res = (fromJust mAgent1, fromJust mAgent2, rdata !! i)++ stop (Just res) ]+ set ca [on command := stop Nothing ]+ + where setJustShape1 = setShape1 . Just + setJustShape2 = setShape2 . Just+ onClick r1 func name state = + do func name state+ mAgent1 <- getShape1 state+ mAgent2 <- getShape2 state+ i <- get r1 selection+ okButton <- getOkButton state+ set okButton [ enabled := if (i==3) then (((fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ) && isJust mAgent1)+ else (isJust mAgent1 && isJust mAgent2)+ ]+ logSelect pal p2 state f w+ = do ;i <- get w selection+ ;mAgent2 <- getShape2 state+ ;mAgent1 <- getShape1 state+ ;okButton <- getOkButton state+ ;if (i == 3) + then do ;set okButton [enabled := (fromMaybe "" mAgent2) `elem` ["Erase","duplicator","copy"] ] + ;let specialPalette = filter (\x -> (fst x) == "Erase" || (fst x) == "duplicator" || (fst x) == "copy" ) pal+ ;if (null specialPalette) + then do ;theFrame <- getNetworkFrame state+ ;errorDialog theFrame "Not Defined" "No rules defined for any of the symbols in the pallete"+ ;set w [selection := 1]+ else do{ ; windowChildren p2 >>= mapM objectDelete + ; n <- panel p2 []+ ;reallyBuildVisiblePalette (Palette specialPalette) n state f+ } + else do {;set okButton [enabled := (isJust mAgent1 && isJust mAgent2) ] + ; windowChildren p2 >>= mapM objectDelete + ; n <- panel p2 []+ ;reallyBuildVisiblePalette (Palette pal) n state f+ }++++++createAgentByNameDialog :: State g n e -> IO (Maybe (String, Shape, [Port]))+createAgentByNameDialog state =+ do theFrame <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ + -- palette shape names+ let paletteNames = map fst . shapes $ getPalette doc++ -- create Dialog + diaW <- dialog theFrame [ text := "Create new symbol"+-- , visible := True+ , resizeable := True+ , clientSize := sz 200 300+ ]+ p <- panel diaW []+ nb <- notebook p []++ p1 <- panel nb []+ agent1 <- entry p1 [text := "Symbol name"]+ -- set agent [ on keyboard := \k -> do propagateEvent+ -- agentD <- get agent text+ -- if agentD `elem` paletteNames + -- then set agent [bgcolor := red]+ -- else set agent [bgcolor := green] ]+ symb1 <- entry p1 [text := "Displayed name" ]+ -- set symb [ on keyboard := \k -> do propagateEvent+ -- set symb [ bgcolor := green ]+ -- repaint agentG+ portsC1 <- textCtrl p1 [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]+ -- set portsC [ on keyboard := \k -> do propagateEvent+ -- portsT <- get portsC text+ -- case (reads :: ReadS [Port] ) portsT of+ -- [(ports,"")] -> do set portsC [ bgcolor := green]+ -- repaint agentG + -- _ -> set portsC [ bgcolor := red]++ p2 <- panel nb []+ agent2 <- entry p2 [text := "Symbol name"]+ symb2 <- entry p2 [text := "Displayed name" ]+ portsC2 <- textCtrl p2 [text := "[ (\"port_name\", DoublePoint 0.3 (-0.3))\n]" ]++ p3 <- panel nb []+ symbs3 <- radioBox p3 Vertical (map fst $ shapes managementSymbols)+ [ text := "Management symbols:"+ , selection := 1+ ]++ let (width, height) = (10,10)+ ppi <- getScreenPPI+ agentG <- window p+ [ virtualSize := sz (logicalToScreenX ppi width)+ (logicalToScreenY ppi height)+ , clientSize := sz 300 50+ , fullRepaintOnResize := False+ , bgcolor := wxcolor paneBackgroundColor + , on paint := \dc r -> safetyNet theFrame $ + do page <- notebookGetSelection nb+ case page of+ 0 -> -- Standard symbol+ do { symbD <- get symb1 text+ ; portsT <- get portsC1 text+ + ; case (reads :: ReadS [Port] ) portsT of+ [(ports,"")] -> + if haveRepeateds (map fst ports)+ then logMessage "port names repeated"+ else+ do let shape = + TextInEllipse { shapeStyle = defaultShapeStyle+ , shapeText = symbD}+ + drawFig dc r shape ports []+ + _ -> logMessage "bad parsing in ports" -- return ()+ }+ 1 -> -- Syntactical symbol+ do { symbD <- get symb2 text+ ; portsT <- get portsC2 text+ ; case (reads :: ReadS [Port] ) portsT of+ [(ports,"")] ->+ if haveRepeateds (map fst ports)+ then logMessage "port names repeated"+ else+ do let shape =+ Composite { shapeSegments =+ [ Polygon+ { shapeStyle = defaultShapeStyle+ , shapePerimeter =+ [ DoublePoint 0 (-0.7)+ , DoublePoint (-0.7) 0.15+ , DoublePoint 0.7 0.15+ ]+ }+ , Text { shapeStyle = defaultShapeStyle+ , shapeText = symbD} ]}+ drawFig dc r shape ports []+ _ -> logMessage "bad parsing in ports" -- return ()+ }+ 2 -> -- Management symbol+ do i <- get symbs3 selection+ let (shape, ports, _) = snd $ (shapes managementSymbols) !! i+ drawFig dc r shape ports []+ ]+ set agentG [ on mouse := \p -> repaint agentG+ , on keyboard := \k -> repaint agentG+ ]++ test <- button p [text := "Test", on command := repaint agentG]++ ok <- button p [ text := "Ok"]+ ca <- button p [ text := "Cancel" ]++ set diaW [ layout := container p $ + margin 10 $ fill $ + column 5+ [ + label "New symbol"+ , tabs nb+ [ tab "Standard" . container p1 .+ fill $ grid 5 5+ [[label "Symbol name", hfill $ widget agent1]+ ,[label "Symbol displayed name", hfill $ widget symb1]+ ,[label "list of ports", hfill $ widget portsC1]]+ , tab "Syntactical" . container p2 .+ fill $ grid 5 5+ [[label "Symbol name", hfill $ widget agent2]+ ,[label "Symbol displayed name", hfill $ widget symb2]+ ,[label "list of ports", hfill $ widget portsC2]]+ , tab "Management" . container p3 . fill $ widget symbs3+ ]+ , hfill $ widget test+ , fill $ widget agentG+ , floatBottomRight $ row 5 [widget ok, widget ca]+ ]+ ]++ showModal diaW $ \stop -> + do set ok [on command := + do page <- notebookGetSelection nb+ case page of+ 0 -> -- Standard symbol+ do{ agentD <- get agent1 text+ ; symbD <- get symb1 text+ ; portsT <- get portsC1 text++ ; if agentD `elem` paletteNames + then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."+ -- ; set agent [bgcolor := red]+ }+ else + if agentD `elem` map fst (shapes specialSymbols)+ then errorDialog diaW "Reserved agent name" $ "\"" ++ agentD ++ "\" is a reserved agent name for a special agent.\nPlease import the agent or choose a different name."+ else+ do let shape = TextInEllipse { shapeStyle = defaultShapeStyle+ , shapeText = symbD}+ case (reads :: ReadS [Port] ) portsT of+ [(ports,"")] ->+ if haveRepeateds (map fst ports)+ then errorDialog diaW "Bad Ports" "port names repeated"+ else stop $ Just (agentD, shape, ports)+ _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports" + -- ; set portsC [ bgcolor := red ]+ } + }+ 1 -> -- Syntactical symbol+ do{ agentD <- get agent2 text+ ; symbD <- get symb2 text+ ; portsT <- get portsC2 text++ ; if agentD `elem` paletteNames+ then do { errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."+ -- ; set agent [bgcolor := red]+ }+ else+ if agentD `elem` map fst (shapes specialSymbols)+ then errorDialog diaW "Reserved agent name" $ "\"" ++ agentD ++ "\" is a reserved agent name for a special agent.\nPlease import the agent or choose a different name."+ else+ do let shape =+ Composite { shapeSegments =+ [ Polygon+ { shapeStyle = defaultShapeStyle+ , shapePerimeter =+ [ DoublePoint 0 (-0.7)+ , DoublePoint (-0.7) 0.15+ , DoublePoint 0.7 0.15+ ]+ }+ , Text { shapeStyle = defaultShapeStyle+ , shapeText = symbD} ]}+ case (reads :: ReadS [Port] ) portsT of+ [(ports,"")] ->+ if haveRepeateds (map fst ports)+ then errorDialog diaW "Bad Ports" "port names repeated"+ else stop $ Just (agentD, shape, ports)+ _ -> do { errorDialog diaW "Parse error in list of Ports" "Parse error in list of Ports" + -- ; set portsC [ bgcolor := red ]+ }+ }+ 2 -> -- Management symbol+ do{ i <- get symbs3 selection+ ; let symb = (shapes managementSymbols) !! i+ agentD = fst symb+ (shape, ports, _) = snd symb+ ; if agentD `elem` paletteNames+ then errorDialog diaW "Repeated symbol name" $ "Already exists one symbol with name \"" ++ agentD ++ "\". Choose a different one."+ else+ stop $ Just (agentD, shape, ports)+ }+ ]+ set ca [on command := stop Nothing ]++createHelpWindow :: IO () +createHelpWindow =+ do f <- frame [ text := "Interaction Nets editor help"+ , position := pt 200 20+ , clientSize := sz 300 240 ]++ hw <- htmlWindowCreate f 1 (Rect 50 150 500 150) 5 "theWindow"+ htmlWindowLoadPage hw "html/HowToUse.html"+ set f [layout := fill $ widget hw]++createAboutWindow :: Frame () -> IO ()+createAboutWindow f = + do infoDialog f ("About " ++ toolName) $ + toolName ++ " is an Interaction Nets Editor.\n"+ ++ "The project is mainly developed by\n"+ ++ "Miguel Vilaca < " ++ "jmvilaca@di.uminho.pt" ++" >\n" + ++ "See the project webpage at\n"+ ++ "http://haskell.di.uminho.pt/jmvilaca/INblobs"++++safeAndClear :: Window a -> TextCtrl b -> IO c -> IO ()+safeAndClear theFrame textlog comp =+ safetyNet theFrame $ textCtrlClear textlog >> comp++-- | Add text to a 'TextCtrl' putting it in the given 'Color'.+addTxtOfColor2TextCtrl :: Color -> TextCtrl () -> String -> IO ()+addTxtOfColor2TextCtrl color txt str =+ do+ start <- textCtrlGetInsertionPoint txt+ textCtrlAppendText txt str+ end <- textCtrlGetInsertionPoint txt+ style <- textAttrCreateDefault+ textAttrSetTextColour style color+ textCtrlSetStyle txt start end style+ return ()++addError2TextCtrl, addGood2TextCtrl :: TextCtrl () -> String -> IO ()+addError2TextCtrl = addTxtOfColor2TextCtrl red+addGood2TextCtrl = addTxtOfColor2TextCtrl green++-- | Add text to a 'TextCtrl' putting it in the current position.+addTxtInPlace2TextCtrl :: TextCtrl () -> String -> IO ()+addTxtInPlace2TextCtrl t str =+ do+ pos <- textCtrlGetInsertionPoint t+ textCtrlSetInsertionPoint t pos+ textCtrlWriteText t str+
+ src/Constants.hs view
@@ -0,0 +1,64 @@+module Constants where++import Graphics.UI.WX+import Colors++kSELECTED_WIDTH :: Int+kSELECTED_WIDTH = 3++kEDGE_CLICK_RANGE, kNODE_RADIUS, kARROW_SIZE:: Double+kEDGE_CLICK_RANGE = 0.2+kNODE_RADIUS = 1.0+kARROW_SIZE = 0.3++kSELECTED_OPTIONS :: [Prop (DC ())]+kSELECTED_OPTIONS = [ penWidth := kSELECTED_WIDTH ]++kNodeLabelColour :: Colour+kNodeLabelColour = licorice++kNodeInfoColour :: Colour+kNodeInfoColour = darkViolet++kNodeMapColour :: Colour+kNodeMapColour = darkSlateGray ++kEdgeLabelColour :: Colour+kEdgeLabelColour = orangeRed++kEdgeInfoColour :: Colour+kEdgeInfoColour = orangeRed++-- ports+kPortRadius = 0.08 :: Double+kPortSelectionRadius = 0.2 :: Double++kPortPenWidth = 0 :: Int+kPortPenColor = yellow :: Color+kPortBrushColor = yellow :: Color++kPrincipalPortPenColor = green :: Color +kPrincipalPortBrushColor = green :: Color +kPrincipalPortSize = 3 :: Int++kInterfacePortPenColor = blue :: Color+kInterfacePortBrushColor = blue :: Color++kPortSelectedColor = red :: Color++palette = "palettes/interface" ++ '.' : paletteExt :: FilePath++-- | The first port in the list of ports is treated differently if 'True'.+hasPrincipalPorts = True :: Bool++toolName = "INblobs" :: String++netExt = "INblobs" :: String++paletteExt = "INblobpalette" :: String++extensions,paletteExtensions :: [(String, [String])]+extensions = [ (toolName ++ " files (." ++ netExt ++ ")", ["*." ++ netExt]) ]+paletteExtensions = [ ("Shape palettes (." ++ paletteExt ++ ")", ["*." ++ paletteExt]) ]++
+ src/ContextMenu.hs view
@@ -0,0 +1,147 @@+module ContextMenu+ ( canvas, edge, node, via ) where++import State+import Network+import Document+import NetworkControl+import SafetyNet+import CommonIO+import Math (DoublePoint)+import qualified PersistentDocument as PD+import Palette+import InfoKind+import Text.Parse+import INReduction++import Graphics.UI.WX+import Graphics.UI.WXCore(windowGetMousePosition)++-- | Context menu for empty area of canvas+canvas :: (InfoKind n g, Show g, Parse g) => Frame () -> State g n e -> IO ()+canvas theFrame state =+ do{ contextMenu <- menuPane []+ ; menuItem contextMenu+ [ text := "Add node (shift-click)"+ , on command := safetyNet theFrame $ addNodeItem theFrame state+ ]+{-+ ; menuItem contextMenu+ [ text := "Edit global info"+ , on command := safetyNet theFrame $ changeGlobalInfo theFrame state+ ]+-}++ ; pointWithinWindow <- windowGetMousePosition theFrame+ ; menuPopup contextMenu pointWithinWindow theFrame+ ; objectDelete contextMenu+ }++addNodeItem :: (InfoKind n g) => Frame () -> State g n e -> IO ()+addNodeItem theFrame state =+ do{ mousePoint <- windowGetMousePosition theFrame+ ; ppi <- getScreenPPI+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint+ ; createNode doubleMousePoint state+ }++-- | Context menu for an edge+edge :: (InfoKind n g, InfoKind e g) =>+ Frame () -> DoublePoint -> State g n e -> Bool -> IO ()+edge theFrame mousepoint state isActivepair =+ do{ contextMenu <- menuPane []+ ; menuItem contextMenu+ [ text := "Add control point"+ , on command := safetyNet theFrame $ createVia mousepoint state+ ]+ ; menuItem contextMenu+ [ text := "Delete edge (Del)"+ , on command := safetyNet theFrame $ deleteSelection state+ ]+{-+ ; menuItem contextMenu+ [ text := "Edit info (i)"+ , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state+ ]+-}+ ; menuItem contextMenu+ [ text := "Reduce active pair"+ , enabled := isActivepair+ , on command := reduce state+ ]+ ; pointWithinWindow <- windowGetMousePosition theFrame+ ; menuPopup contextMenu pointWithinWindow theFrame+ ; objectDelete contextMenu+ }++-- | Context menu for a 'via' point+via :: Frame () -> State g n e -> IO ()+via theFrame state =+ do{ contextMenu <- menuPane []+ ; menuItem contextMenu+ [ text := "Delete control point (Del)"+ , on command := safetyNet theFrame $ deleteSelection state+ ]+ ; pointWithinWindow <- windowGetMousePosition theFrame+ ; menuPopup contextMenu pointWithinWindow theFrame+ ; objectDelete contextMenu+ }++-- | Context menu for a node+node :: (InfoKind n g, InfoKind e g) => Int -> Frame () -> State g n e -> IO ()+node nodeNr theFrame state =+ do{ contextMenu <- menuPane []++ ; pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ theNode = getNode nodeNr network+ labelAbove = getNameAbove theNode+ palette = getPalette doc+ theShape = getShape theNode++ ; aboveItem <- menuRadioItem contextMenu+ [ text := "Label above (up arrow)"+ , checked := labelAbove+ , on command := safetyNet theFrame $ changeNamePosition True state+ ]+ ; belowItem <- menuRadioItem contextMenu+ [ text := "Label below (down arrow)"+ , checked := not labelAbove+ , on command := safetyNet theFrame $ changeNamePosition False state+ ]+-- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ]+ ; menuItem contextMenu+ [ text := "Rename (r)"+ , on command := safetyNet theFrame $ renameNode theFrame state+ ]+{-+ ; menuItem contextMenu+ [ text := "Edit info (i)"+ , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state+ ]+-}++ ; menuLine contextMenu+-- ; mapM_ (shapeItem theShape contextMenu) (shapes palette)+-- ; menuLine contextMenu++ ; menuItem contextMenu+ [ text := "Delete (Del)"+ , on command := safetyNet theFrame $ deleteSelection state+ ]++ ; pointWithinWindow <- windowGetMousePosition theFrame+ ; menuPopup contextMenu pointWithinWindow theFrame+ ; objectDelete contextMenu++ }+ where+ shapeItem curShape contextMenu (name,(shape,ports,info)) =+ menuRadioItem contextMenu+ [ text := ("Shape: "++name)+ , checked := case curShape of { Left n -> n==name; Right s -> False; }+ , on command := safetyNet theFrame $ changeNodeShape name newinfo state+ ]+ where newinfo = maybe blank id info
+ src/DisplayOptions.hs view
@@ -0,0 +1,16 @@+module DisplayOptions where++import Data.List ((\\))++type ShowInfo = [What]+data What = NodeLabel | NodeInfo | EdgeLabel | EdgeInfo deriving (Eq)++data DisplayOptions = DP+ { dpShowInfo :: ShowInfo+ }++standard :: DisplayOptions+standard = DP []++toggle :: What -> DisplayOptions -> DisplayOptions+toggle w (DP opts) = DP (if w `elem` opts then opts\\[w] else w:opts)
+ src/Document.hs view
@@ -0,0 +1,187 @@+{-| Module : Document+ Maintainer : afie@cs.uu.nl++ This module contains functions to create documents+ and to get and set components of the Document datatype.+-}++module Document+ ( Document+ , RuleName+ , ActiveCanvas(..) + , Selection(..)+ , empty+ , getNetwork, setNetwork, unsafeSetNetwork+ , getPalette, setPalette+ , getSelection, setSelection+ , getRules, setRules++ , updateNetwork, updateNetworkEx+ , joinPalette+ , updateRules+ , selectNetwork+ , updateSelNetwork, updateSelNetworkEx+ , removeMappingElemWithNode+ , show'+ ) where++import Network hiding (empty)+import INRule+import INRules hiding (empty) +import InfoKind+import Math+import Ports+import Palette hiding (delete, empty)+import qualified Network (empty)+import qualified INRules (empty) +import qualified Palette (empty)++import Data.Maybe++{--------------------------------------------------+ -- TYPES+ --------------------------------------------------}++data Document g n e = Document+ { docNetwork :: Network g n e+ , docPalette :: Palette n -- ^ the current 'Palette'+ , docSelection :: Selection+ , docRules :: INRules g n e+ } deriving Show++type RuleName = String+data ActiveCanvas = Net | LHS RuleName | RHS RuleName deriving (Show, Eq, Read)++data Selection+ = NoSelection+ | NodeSelection ActiveCanvas Int (Maybe PortName)+ | EdgeSelection ActiveCanvas Int+ | ViaSelection ActiveCanvas Int Int+ | MultipleSelection ActiveCanvas + (Maybe (DoublePoint,DoublePoint)) [Int] [(Int,Int)]+ -- DoublePoint pair is for displaying dragged selection rectangle+ deriving (Show, Read, Eq)++{--------------------------------------------------+ -- CREATION+ --------------------------------------------------}+++-- | An empty document+empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e+empty g n e =+ Document+ { docNetwork = Network.empty g n e+ , docPalette = Palette.empty+ , docSelection = NoSelection+ , docRules = INRules.empty g n e+ }++{--------------------------------------------------+ -- GETTERS+ --------------------------------------------------}++getNetwork :: Document g n e -> Network g n e+getPalette :: Document g n e -> Palette n+getSelection :: Document g n e -> Selection+getRules :: Document g n e -> INRules g n e++getNetwork doc = docNetwork doc+getPalette doc = docPalette doc+getSelection doc = docSelection doc+getRules doc = docRules doc++{--------------------------------------------------+ -- SETTERS+ --------------------------------------------------}++-- | setNetwork clears the selection because the node may not exist+-- in the new network+setNetwork :: Network g n e -> Document g n e -> Document g n e+setNetwork theNetwork doc =+ doc { docNetwork = theNetwork+ , docSelection = NoSelection+ }++setPalette :: Palette n -> Document g n e -> Document g n e+setPalette thePalette doc = doc { docPalette = thePalette }++setSelection :: Selection -> Document g n e -> Document g n e+setSelection theSelection doc = doc { docSelection = theSelection }++setRules :: INRules g n e -> Document g n e -> Document g n e+setRules theRules doc = doc {docRules = theRules}++updateNetwork :: (Network g n e -> Network g n e)+ -> Document g n e -> Document g n e+updateNetwork networkFun doc+ = unsafeSetNetwork (networkFun (getNetwork doc))+ $ doc++updateNetworkEx :: (Network g n e -> (b, Network g n e))+ -> Document g n e -> (b, Document g n e)+updateNetworkEx networkFun doc =+ let (result, newNetwork) = networkFun (getNetwork doc)+ in ( result+ , unsafeSetNetwork newNetwork doc+ )++joinPalette :: (Eq n) => Palette n -> Document g n e -> Document g n e+joinPalette palette doc = doc { docPalette = join (getPalette doc) palette }++updateRules :: (INRules g n e -> INRules g n e) + -> Document g n e -> Document g n e+updateRules rulesFun doc = doc { docRules = rulesFun $ docRules doc }++-- | Doesn't clear the selection+unsafeSetNetwork :: Network g n e -> Document g n e -> Document g n e+unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork }++-- | Given a document and the active canvas this function selects +-- the corresponding network.+selectNetwork :: Document g n e -> ActiveCanvas -> Network g n e+selectNetwork doc canvas =+ case canvas of+ Net -> getNetwork doc+ LHS ruleName -> fromMaybe (erro ruleName)+ $ getLHS `fromRule` ruleName $ getRules doc+ RHS ruleName -> fromMaybe (erro ruleName) + $ getRHS `fromRule` ruleName $ getRules doc+ where erro ruleName = error $ "This shouldn't happen because << "+ ++ ruleName ++ " >> must be a rule."++-- | Given a document and the active canvas this function updates +-- the corresponding network accordingly the the updater network +-- function given as an argument.+updateSelNetwork :: (Network g n e -> Network g n e)+ -> ActiveCanvas -> Document g n e -> Document g n e+updateSelNetwork netFunc canvas doc =+ case canvas of + Net -> updateNetwork netFunc doc+ LHS ruleName -> updateRules (updateRule ruleName $ updateLHS netFunc) doc+ RHS ruleName -> updateRules (updateRule ruleName $ updateRHS netFunc) doc++updateSelNetworkEx :: (Network g n e -> (b, Network g n e))+ -> ActiveCanvas -> Document g n e -> (b, Document g n e)+updateSelNetworkEx networkFun canvas doc =+ let (result, newNetwork) = networkFun (selectNetwork doc canvas)+ in ( result+ , case canvas of+ Net -> unsafeSetNetwork newNetwork doc+ LHS ruleName -> updateRules (updateRule ruleName + $ setLHS newNetwork) doc+ RHS ruleName -> updateRules (updateRule ruleName + $ setRHS newNetwork) doc+ )++removeMappingElemWithNode :: ActiveCanvas -> NodeNr -> Document g n e -> Document g n e+removeMappingElemWithNode canv nodeNr = + case canv of+ Net -> id+ LHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . fst+ RHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . snd++show' :: ActiveCanvas -> String+show' Net = "net"+show' (LHS rule) = "rule " ++ rule ++ "'s LHS"+show' (RHS rule) = "rule " ++ rule ++ "'s RHS"
+ src/DocumentFile.hs view
@@ -0,0 +1,145 @@+module DocumentFile where+++import Document as Doc+import Palette+import Shape+import Ports+import INRule+import InfoKind+import NetworkFile++import Text.XML.HaXml.Types+import Text.XML.HaXml.Posn (noPos)+import Text.XML.HaXml.Parse+import Text.XML.HaXml.XmlContent as XML+import Text.PrettyPrint.HughesPJ+import qualified Text.XML.HaXml.Pretty as Pretty+++-- | Print the document data structure to an XML text+toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ Doc.Document g n e -> String+toString doc = render . Pretty.document $+ Document (Prolog Nothing [] Nothing []) emptyST (f (toContents doc)) []+ where+ f [CElem e _] = e+ f _ = error "bad" -- shouldn't happen++-- | Parses a string to the document data structure+-- Returns either an error message (Left) or the document,+-- a list of warnings (Right) and a boolean indicating whether+-- the file was an old INBlobs file+fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ String -> Either String (Doc.Document g n e, [String], Bool)+fromString xml =+ case xmlParse' "input file" xml of+ Left err -> Left err -- lexical or initial (generic) parse error+ Right (Document _ _ e _) ->+ case runParser parseContents [CElem e noPos] of+ (Left err, _) -> Left err -- secondary (typeful) parse error+ (Right v, _) -> Right (v,[],False)++++instance HTypeable (Doc.Document g n e) where+ toHType _ = Defined "Document" [] [Constr "Document" [] []]+instance (InfoKind n g, InfoKind e g, XmlContent g) =>+ XmlContent (Doc.Document g n e) where+ toContents document = + [CElem (Elem "Document" []+ $ (toContents $ getNetwork document)+ ++ (toContents $ getPalette document)+ ++ [ makeTag "Rules" (concatMap toContents+ $ getRules document)+ ]) () ]+ parseContents = do+ { inElement "Document" $ do+ { net <- parseContents+ ; pal <- parseContents+ ; rus <- inElement "Rules" $ many1 parseContents+ ; return ( setRules rus+ . setPalette pal+ . setNetwork net+ $ Doc.empty undefined undefined undefined)+ }+ }++instance HTypeable a => HTypeable (Palette a) where+ toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []]+ where (Palette ((_,(_,_,Just a)):_)) = p+instance XmlContent a => XmlContent (Palette a) where+ toContents (Palette shapes) =+ [ mkElemC "Palette" (map aux shapes) ]+ where+ -- aux :: (ShapeName,(Shape,Ports,Maybe a)) -> Content ()+ aux (name,(shape,pPort:ports, info)) =+ CElem (Elem "Symbol" []+ [ escapeString "ShapeName" name+ , makeTag "Shape" $ toContents shape+ , makeTag "Ports"+ [ makeTag "Principals" [auxPort pPort]+ , makeTag "Auxiliaries" $ map auxPort ports]+ , makeTag "Info" $ toContents info+ ]) ()+ auxPort :: Port -> Content ()+ auxPort = makeTag "Port" . toContents+ parseContents = do+ { inElement "Palette" $ fmap Palette (many1 parseSymbol) }++parseSymbol :: (XmlContent a) => XMLParser (ShapeName,(Shape,Ports,Maybe a))+parseSymbol = do+ { inElement "Symbol" $ do+ { name <- inElement "ShapeName" $ XML.text+ ; shape <- inElement "Shape" $ parseContents+ ; ([pP],aPs) <- inElement "Ports" $ parsePorts+ ; info <- inElement "Info" $ parseContents+ ; return (name,(shape,pP:aPs,info)) } }++parsePorts :: XMLParser (Ports,Ports)+parsePorts =+ do+ pPorts <- inElement "Principals" $ many1 parsePort -- principal ports+ aPorts <- inElement "Auxiliaries" $ many parsePort -- auxiliary ports+ return (pPorts, aPorts)++parsePort :: XMLParser Port+parsePort = inElement "Port" $ parseContents++instance HTypeable (INRule g n e) where+ toHType _ = Defined "INRule" [] [Constr "INRule" [] []]+instance (InfoKind n g, InfoKind e g, XmlContent g) =>+ XmlContent (INRule g n e) where+ toContents rule = + [CElem (Elem "INRule" []+ [ escapeString "Name" (getName rule)+ , makeTag "LHS" (toContents $ getLHS rule)+ , makeTag "RHS" (toContents $ getRHS rule)+ , makeTag "Mapping" (map toContentsMappingElement+ $ getMapping rule)+ ]) () ]+ where+ toContentsMappingElement :: MappingElement -> Content ()+ toContentsMappingElement (nNr1,nNr2) =+ CElem (Elem "MappingElement"+ [ mkAttr "lhs" (show nNr1)+ , mkAttr "rhs" (show nNr2)+ ] []) ()+ parseContents = do+ { inElement "INRule" $ do+ { nam <- inElement "Name" $ XML.text+ ; lhs <- inElement "LHS" $ parseContents+ ; rhs <- inElement "RHS" $ parseContents+ ; maa <- inElement "Mapping" $ many parseMappingElement+ ; return ( INRule.construct nam lhs rhs maa)+ }+ }++parseMappingElement :: XMLParser MappingElement+parseMappingElement = do+ { (p, e@(Elem _ [("lhs",nNr1),("rhs",nNr2)] [])) <- posnElement ["MappingElement"]+ ; nNr1' <- attr2value nNr1+ ; nNr2' <- attr2value nNr2+ ; return (nNr1', nNr2')+ }+
+ src/Functional/Compiler.hs view
@@ -0,0 +1,539 @@+{-|+ Module : Functional.Compiler+ Copyright : (c) Daniel Mendes and Miguel Vilaça 2007+ Maintainer : danielgomesmendes@gmail.com and jmvilaca@di.uminho.pt+ Stability : experimental+ Portability : portable++ Small Functional Language: Compiler -}+module Functional.Compiler ( compile) where++import Network+import InfoKind+import Palette+import Shape+import Document+import Ports+import Math+import List+import INRule+import INRules+import Common+import CommonUI++import Functional.Language++import Data.Maybe+import Data.List+import qualified Data.Map as Map+++type Context = Map.Map Variable ConnectionPoint+data AgentType = Syntactical | Computational+++-- | Given a strategy, a closed term and a list of names for iter agents,+-- update the document with the dynamic part of the IN system.+compile :: (Eq n, InfoKind n g, InfoKind e g) => g -> n -> e -> CallBy -> FuncLang -> [(FuncLang, String)] -> Document g n e -> IO (Document g n e)+compile g n e callBy term names doc+ | callBy `elem` [Name,Value] =+ -- add iter symbols+ let symbs = foldr (\h r-> createIterSymbol Syntactical h : createIterSymbol Computational h :r) [] names+ repeated = map fst symbs `intersect` (shapesNames $ getPalette doc)+ in if null repeated+ then+ do+ let doc1 = joinPalette (Palette symbs) doc+ palette = getPalette doc1+ tokenRules <- mapM (createIterTokenRule g n e palette) names+ lrules <- mapM (createIterConstructorRules g n e palette names) names+ return $ setNetwork (draw term names palette $ Network.empty g n e)+ $ updateRules (++ tokenRules ++ concat lrules) doc1+ else fail $ "Give different names to iter symbols. This ones are already in use:\n"+ ++ commasAnd repeated++ | otherwise = fail "unknown strategy"+++-- | Create the main net.+draw ::(InfoKind n g, InfoKind e g) => FuncLang -> [(FuncLang, String)] -> Palette n -> Network g n e -> Network g n e+draw t names p network = let (x,net) = addNode "interface" p network+ (n,net1) = addNode "evaluation" p net+ net2 = setNodePosition n (DoublePoint 15 1.03)+ . setNodePosition x (DoublePoint 15 0.01)+ . connectNodes p (x,"interface","interface") (n,"evaluation","res") $ net1+ in iso p names (n,"evaluation","arg") (0,1.6) t Map.empty net2++-- | The \cal{T} function of the paper.+iso :: (InfoKind n g, InfoKind e g) => Palette n+ -> [(FuncLang, String)] -- ^ list of names for Iter_TYPE symbols+ -> ConnectionPoint -- point to connect the root of the IN term+ -> (Double,Double) -- translation from connection node+ -> FuncLang -- term to translate to INs+ -> Context -- free variables and their respective connection points+ -> Network g n e -- already constructed net+ -> Network g n e -- resulting net+iso palette names point trans term ctx net = -- trace ("ISO: TERM: " ++ show term ++ " CTX: " ++ show (Map.keys ctx)) $+ case term of+ Var v -> case Map.lookup v ctx of+ Just pointVar -> connectNodes palette point pointVar net+ Nothing -> error $ "Internal Error: variable \"" ++ v ++ "\" is not in context " ++ show (Map.keys ctx)++ Abst v t -> let (abstNr, net1) = addNode "lambda" palette net+ net2 = connectNodes palette point (abstNr,"lambda","res")+ . moveNode abstNr trans point+ $ net1+ abstPoint = translate (getNodePosition net2 abstNr) (DoublePoint (-1) 1)+ (net3, ctx1) = if v `elem` (freeVars t)+ then (net2, Map.insert v (abstNr,"lambda","var") ctx)+ else let (eraseNr,net4) = addNode "Erase" palette net2+ in (connectNodes palette (eraseNr,"Erase","down") (abstNr,"lambda","var")+ $ setNodePosition eraseNr abstPoint net4, ctx)+ in iso palette names (abstNr,"lambda","body") (1,1.2) t ctx1 net3++ Appl t u -> createNet2 "beforeApplication" t "func" u "arg"+ TT -> createNet0 "True"+ FF -> createNet0 "False"+ Zero -> createNet0 "Zero"+ Succ t -> createNet1 "Succ" t "arg"+ Nil -> createNet0 "Nil"+ Cons t u -> createNet2 "Cons" t "head" u "tail"+ iter@(IterBool v f b) -> createNetIter iter [(v, 'v'),(f, 'f')] b "arg"+ iter@(IterNat x s z n) -> createNetIter iter [(Abst x s, 's'),(z, 'z')] n "arg"+ iter@(IterList x y c n l) -> createNetIter iter [(Abst x $ Abst y c, 'c'),(n, 'n')] l "arg"+ _ -> error "Internal Error: none exaustive patterns in function iso."+ where+ -- | Create a net with the agent of arity 0 and connect it to the given point.+ -- createNet0 :: String -> Network g n e+ createNet0 agentName = let (nr, net1) = addNode agentName palette net+ in connectNodes palette point (nr,agentName,"res")+ $ moveNode nr trans point net1++ -- | Create a net with the agent of arity 1 and connect+ -- it to the given point and to the translation of the subterm.+ -- createNet1 :: String -> FuncLang -> PortName -> Network g n e+ createNet1 agentName term portName =+ let (nr, net1) = addNode agentName palette net+ in iso palette names (nr,agentName,portName) (0,1) term ctx+ . connectNodes palette point (nr,agentName,"res")+ . moveNode nr trans point+ $ net1++ -- | Create a net with the agent of arity 2 and connect it to the given+ -- point and to the subterms, taking care of shared variables.+ -- createNet2 :: String -> FuncLang -> PortName -> FuncLang -> PortName -> Network g n e+ createNet2 agentName tLeft portLeft tRight portRight =+ let (nr, net1) = addNode agentName palette net+ net2 = connectNodes palette point (nr,agentName,"res")+ . moveNode nr trans point+ $ net1+ (net3, [ctxL,ctxR]) = shareCommonVariables palette [tLeft, tRight] ctx net2+ in iso palette names (nr,agentName,portLeft) (-5,1) tLeft ctxL+ . iso palette names (nr,agentName,portRight) (5,1) tRight ctxR+ $ net3++ -- | Create a net with the iter agent and connect it to the given+ -- point and to the subterms, taking care of shared variables.+ -- createNetIter :: FuncLang -- iter_TYPE term+ -- -> [(FuncLang, Char)] -- list of sub terms and respective port prefixs+ -- -> FuncLang -- middle (arg) sub term+ -- -> PortName -- middle (arg) port name+ -- -> Network g n e+ createNetIter term l tMiddle portMiddle =+ case lookupIterName term names of+ Just agentName ->+ let (nr, net1) = addNode agentName palette net+ net2 = connectNodes palette point (nr,agentName,"res")+ . moveNode nr trans point+ $ net1+ (terms,portPrefixs) = unzip l+ (net3, ctxM:ctxs) = shareCommonVariables palette (tMiddle:terms) ctx net2+ in iso palette names (nr,agentName,portMiddle) (0,1.5) tMiddle ctxM+ . foldlCont (connect2Iter nr agentName) (zip portPrefixs ctxs)+ $ net3+ Nothing -> error $ "Internal Error: symbol " ++ show term ++ "not found in list of symbol's names."++ -- connect2Iter :: (InfoKind e g) => NodeNr -> String -> Network g n e -> (Char,Context) -> Network g n e+ connect2Iter nr agentName net (portPrefix, ctx) =+ connectPorts palette portPrefix nr agentName ctx net++-- | Connect the set of ports with prefix 'pF' from given agent to the context.+connectPorts :: (InfoKind e g) => Palette n ->+ Char -- port prefix+ -> NodeNr -- iter agent+ -> String -- iter agent+ -> Context+ -> Network g n e -> Network g n e+connectPorts palette pF iterNr iterAgent ctx net = Map.foldWithKey (connectIterZs iterNr) net ctx+ where -- connectIterZs :: (InfoKind e g) => NodeNr+ -- -> Variable -> ConnectionPoint -> Network g n e+ -- -> Network g n e+ connectIterZs iterNr var point net =+ connectNodes palette (iterNr,iterAgent,pF:'_':var) point net+++type RichCtx = Map.Map Variable [ConnectionPoint]++-- | Add as many copy agents as necessary for variables that are shared between sub-terms.+shareCommonVariables :: (InfoKind n g,InfoKind e g) =>+ Palette n+ -> [FuncLang] -- list of n subterms+ -> Context+ -> Network g n e+ -> (Network g n e, [Context]) -- new net with necessary copy agents+ -- and n contexts: respectively for each subterm+shareCommonVariables palette l ctx net =+ let+ lVars = map freeVars l+ (net1, richCtx) =+ Map.mapAccumWithKey copyPointInNet net . Map.mapWithKey count $ ctx+ in (net1, snd $ mapAccumL subTermCtx richCtx lVars)+ where+ lVars = map freeVars l++ count :: Variable -> ConnectionPoint -> (Int, ConnectionPoint)+ count var point = (length $ findIndices (var `elem`) lVars, point)++-- copyPointInNet :: (InfoKind n g,InfoKind e g) =>+-- Network g n e -> Variable -> (Int, ConnectionPoint)+-- -> (Network g n e, [ConnectionPoint])+ copyPointInNet net _ (0, point) = error "Internal Error in copyPointInNet"+ copyPointInNet net _ (1, point) = (net, [point])+ copyPointInNet net v (n, point) =+ let (nNr, net1) = addNode "copy" palette net+ m = n `div` 2+ net2 = moveNode nNr (-1.5,1) point+ $ connectNodes palette point (nNr,"copy","src") net1+ (netL, pointsL) = copyPointInNet net2 v (m , (nNr,"copy","fst_target"))+ (netR, pointsR) = copyPointInNet netL v (n-m, (nNr,"copy","snd_target"))+ in (netR, pointsL ++ pointsR)++++ subTermCtx :: RichCtx -> [Variable] -> (RichCtx, Context)+ subTermCtx richctx = (id >< Map.fromList) . mapAccumL variableCtx richctx++ variableCtx :: RichCtx -> Variable -> (RichCtx, (Variable,ConnectionPoint))+ variableCtx richctx var = (Map.adjust tail var richctx, (var, head $ richctx Map.! var))++-- | Connect unused variables to erase agents.+closeEpsilon ::(InfoKind n g, InfoKind e g) => Palette n -> Context -> Network g n e -> Network g n e+closeEpsilon pal ctx net = Map.fold aux net ctx+ where+ -- aux :: ConnectionPoint -> Network g n e -> Network g n e+ aux point nt = let (node_nr, n_nt) = addNode "Erase" pal nt+ in connectNodes pal point (node_nr,"Erase","down")+ . moveNode node_nr (0,-1) point+ $ n_nt++createIterSymbol :: AgentType -> (FuncLang, String) -> (String, (Shape, Ports, Maybe a))+createIterSymbol at (term, name) = (name2, (shape, ports, Nothing))+ where+ (x,y) = (1.0, 1.0)+ topPosition = DoublePoint 0.0 (-y)+ name2 = case at of+ Syntactical -> name+ Computational -> '^':name+ shape =+ case at of+ Syntactical -> -- triangle with text+ Composite { shapeSegments =+ [ Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1+ , styleStrokeColour = licorice+ , styleFill = lightRed }+ , shapePerimeter = [topPosition, DoublePoint (-x) 0.3, DoublePoint x 0.3] }+ , Text { shapeStyle = defaultShapeStyle+ , shapeText = name }+ ] }+ Computational -> -- circle+ TextInEllipse { shapeStyle = ShapeStyle { styleStrokeWidth = 1+ , styleStrokeColour = licorice+ , styleFill = lightRed }+ , shapeText = name }+ (resP,argP) = case at of+ Syntactical -> (("res", topPosition),("arg", DoublePoint 0.0 0.3))+ Computational -> (("arg", DoublePoint 0.0 0.3),("res", topPosition))++ ports =+ case term of+ IterBool v f (Var "") -> resP: portsFrom (-x) 'v' v ++ argP: portsFrom x 'f' f+ IterNat a s z (Var "") -> resP: portsFrom (-x) 's' (Abst a s) ++ argP: portsFrom x 'z' z+ IterList a b c n (Var "") -> resP: portsFrom (-x) 'c' (Abst a $ Abst b c) ++ argP: portsFrom x 'n' n+ _ -> error "unexpected case"+ portsFrom :: Double -> Char -> FuncLang -> [Port]+ portsFrom pos char term = snd . mapAccumL (createPort char desc) pos $ freeVars term+ where desc = (signum pos) * (-0.3)++createPort :: Char -> Double -> Double -> String -> (Double, Port)+createPort c desc x str = (x + desc, (c:'_':str, DoublePoint x 0.3))++createIterTokenRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> (FuncLang, String) -> IO (INRule g n e)+createIterTokenRule g n e palette (_, agent) =+ do+ (rule,nNr1,nNr2) <- createRuleWizard g n e palette "evaluation" agent+ portsEval <- getSymbolPorts "evaluation" palette+ return . updateRHS (f (map fst portsEval) ('^':agent) nNr1 nNr2) $ copyLHS2RHS rule+ where+ -- f :: (InfoKind e g) => [PortName] -> ShapeName -> NodeNr -> NodeNr -> Network g n e -> Network g n e+ f ["arg","res"] shape2 nNr1 nNr2 net =+ let pos1 = getNodePosition net nNr1+ pos2 = getNodePosition net nNr2+ mid = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "arg"+ top = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr1 "res"+ bot = fromJust $ otherExtremeOfEdgeConnectedOnPort net nNr2 "arg"+ arc1 = fromJust $ edgeConnectedOnPort net nNr1 "arg"+ arc2 = fromJust $ edgeConnectedOnPort net nNr1 "res"+ arc3 = fromJust $ edgeConnectedOnPort net nNr2 "arg"++ in addEdges palette+ [ ((nNr2,"arg"),(nNr1,"res")) -- (iter,arg) |-> (token,res)+ , (top,(nNr2,"res")) -- top interface |-> (iter,res)+ , ((nNr1,"arg"), bot) -- (token,arg) |-> bottom interface+ ]+ . removeEdge arc1 . removeEdge arc2 . removeEdge arc3+ . setNodeShape nNr2 shape2 -- change symbol iter to ^iter+ . setNodePosition nNr1 pos2 . setNodePosition nNr2 pos1 -- swap positions+ $ net+ f _ _ _ _ _ = error $ "Internal Error: creating rule for token and " ++ agent++createIterConstructorRules :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> IO (INRules g n e)+createIterConstructorRules g n e palette names (term, agent) =+ mapM (createIterConstructorRule g n e palette names (term, agent) ) constructorAgents+ where constructorAgents = case term of+ IterBool _ _ (Var "") -> ["True","False"]+ IterNat _ _ _ (Var "") -> ["Zero","Succ"]+ IterList _ _ _ _ (Var "") -> ["Nil","Cons"]+ -- new Iterators+ _ -> error "Internal Error: iterator term expected and something different found."+++data InterfaceID =+ RES ConnectionPoint+ | SuccArg ConnectionPoint+ | ConsHead ConnectionPoint+ | ConsTail ConnectionPoint+ | IterBoolV Context+ | IterBoolF Context+ | IterNatS Context+ | IterNatZ Context+ | IterListC Context+ | IterListN Context+ deriving(Eq,Ord,Show)++equalIID :: InterfaceID -> InterfaceID -> Bool+equalIID (RES _) (RES _) = True+equalIID (SuccArg _) (SuccArg _) = True+equalIID (ConsHead _) (ConsHead _) = True+equalIID (ConsTail _) (ConsTail _) = True+equalIID (IterBoolV _) (IterBoolV _) = True+equalIID (IterBoolF _) (IterBoolF _) = True+equalIID (IterNatS _) (IterNatS _) = True+equalIID (IterNatZ _) (IterNatZ _) = True+equalIID (IterListC _) (IterListC _) = True+equalIID (IterListN _) (IterListN _) = True+equalIID _ _ = False++createIterConstructorRule :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Palette n -> [(FuncLang, String)] -> (FuncLang, String) -> String -> IO (INRule g n e)+createIterConstructorRule g n e palette names (term, agent) agent2 =+ do+ (rule,nNr1,nNr2) <- createRuleWizard g n e palette ('^':agent) agent2+ let lhs = getLHS rule+ (_:lPorts1) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr1+ (_:lPorts2) = map fst . maybe (error "Internal Error: unexpected Nothing") id $ getPorts palette lhs nNr2+ groupedInterfaces = groupInterfaces lhs (nNr1, lPorts1) (nNr2, lPorts2)++ return . updateRHS (makeRHS term agent agent2 groupedInterfaces) $ copyLHSInterface2RHS rule+ where+ groupInterfaces :: Network g n e -> (NodeNr, [PortName]) -> (NodeNr, [PortName])+ -> [InterfaceID]+ groupInterfaces lhs (nNr1, auxPorts1) (nNr2, auxPorts2) =+ sort (f4 nNr1 auxPorts1) ++ f4 nNr2 auxPorts2+ where+ f4 :: NodeNr -> [PortName] -> [InterfaceID]+ f4 nNr = map (f3 lhs nNr) . groupBy aux++ f3 :: Network g n e -> NodeNr -> [PortName] -> InterfaceID+ f3 net nNr = aux3+ where+ aux3 [p@"res" ] = RES $ f2 p+ aux3 [p@"head"] = ConsHead $ f2 p+ aux3 [p@"tail"] = ConsTail $ f2 p+ aux3 [p@"arg" ] = SuccArg $ f2 p+ aux3 l@(('v':'_':_):_) = IterBoolV . f6 $ l+ aux3 l@(('f':'_':_):_) = IterBoolF . f6 $ l+ aux3 l@(('s':'_':_):_) = IterNatS . f6 $ l+ aux3 l@(('z':'_':_):_) = IterNatZ . f6 $ l+ aux3 l@(('c':'_':_):_) = IterListC . f6 $ l+ aux3 l@(('n':'_':_):_) = IterListN . f6 $ l+ aux3 _ = error "Internal Error in aux3"++ f2 :: PortName -> ConnectionPoint+ f2 = f4 . maybe (error "Internal Error: unexpected Nothing") id . otherExtremeOfEdgeConnectedOnPort net nNr++ f4 (nNr,"interface") = (nNr,"interface","interface")+ f4 _ = error "Internal Error: unexpected agent"++ f5 (_:'_':portName) = portName+ f5 _ = error "Internal Error: unexpected port name"++ f6 = Map.fromList . map (f5 /\ f2)++ -- makeRHS :: FuncLang -> String -> String -> [InterfaceID] -> Network g n e -> Network g n e+ makeRHS term iterAgent consAgent (RES interfacePoint:lInters) net =+ let (conE,net1) = connectToken palette interfacePoint net+ in reallyMakeRHS palette names term iterAgent consAgent lInters conE net1+ makeRHS _ _ _ _ _ = error "Internal Error making RHS."++-- | Add a token agent and connect its auxiliar port to the given point.+connectToken :: (InfoKind n g, InfoKind e g) => Palette n -> ConnectionPoint -> Network g n e -> (ConnectionPoint, Network g n e)+connectToken palette topPoint net =+ let (nNrE, net1) = addNode "evaluation" palette net -- add token agent+ in ( (nNrE,"evaluation","arg")+ , connectNodes palette (nNrE, "evaluation", "res") topPoint -- (token, res) |-> topPoint+ . moveNode nNrE (0,1) topPoint+ $ net1 )++aux :: PortName -> PortName -> Bool+aux (c1:'_':_) (c2:'_':_) = c1 == c2+aux _ _ = False++-- | Creates the network that is the RHS of rule for given symbols.+-- See interaction rules for iterators in paper+-- "Encoding Iterators in Interaction Nets" for more details.+reallyMakeRHS :: (InfoKind n g, InfoKind e g)+ => Palette n+ -> [(FuncLang, String)]+ -> FuncLang -- Iter_TYPE args (Var "")+ -> String -- iter agent name+ -> String -- constructor agent name+ -> [InterfaceID] -> ConnectionPoint+ -> Network g n e -> Network g n e+reallyMakeRHS palette names term iterAgent const l point =+ case (term, const) of+ (IterBool v _ (Var ""), "True") ->+ case emptyfy l [IterBoolV emp, IterBoolF emp] of+ [IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxV ctxF v+ _ -> error "Internal Error: unexpected [InterfaceID]"+ (IterBool _ f (Var ""), "False") ->+ case emptyfy l [IterBoolV emp, IterBoolF emp] of+ [IterBoolV ctxV, IterBoolF ctxF] -> simpleRHS palette names point ctxF ctxV f+ _ -> error "Internal Error: unexpected [InterfaceID]"+ (IterNat _ _ z (Var ""), "Zero") ->+ case emptyfy l [IterNatS emp, IterNatZ emp] of+ [IterNatS ctxS, IterNatZ ctxZ] -> simpleRHS palette names point ctxZ ctxS z+ _ -> error "Internal Error: unexpected [InterfaceID]"+ (IterNat x s _ (Var ""), "Succ") ->+ case emptyfy l [IterNatS emp, IterNatZ emp, SuccArg undef] of+ [IterNatS ctxS, IterNatZ ctxZ, SuccArg pSucArg] ->+ oneRecursiveCallRHS palette names point ctxS emp ctxZ pSucArg x s iterAgent 'z' 's'+ _ -> error "Internal Error: unexpected [InterfaceID]"+ (IterList _ _ _ n (Var ""), "Nil") ->+ case emptyfy l [IterListC emp, IterListN emp] of+ [IterListC ctxC, IterListN ctxN] -> simpleRHS palette names point ctxN ctxC n+ _ -> error "Internal Error: unexpected [InterfaceID]"+ (IterList x y c _ (Var ""), "Cons") ->+ case emptyfy l [IterListC emp, IterListN emp, ConsHead undef, ConsTail undef] of+ [IterListC ctxC, IterListN ctxN, ConsHead pConsHead, ConsTail pConsTail] ->+ oneRecursiveCallRHS palette names point ctxC (Map.singleton x pConsHead) ctxN pConsTail y c iterAgent 'n' 'c'+ _ -> error "Internal Error: unexpected [InterfaceID]"+ _ -> error "Undefined case making RHS."+ where emp = Map.empty+ undef = (0,"INVALID NODE","")++emptyfy :: [InterfaceID] -> [InterfaceID] -> [InterfaceID]+emptyfy given needed = map (\e -> maybe e id $ find (equalIID e) given ) needed+++-- | Defines a simple RHS that evaluates the translation of term t+-- connecting its free variables to the corresponding interface agents+-- and connects the remaing interface agents to erase agents.+-- For example RHS for rule IterBool |X| TT that is+-- \TOKEN(T(V))+simpleRHS :: (InfoKind n g, InfoKind e g)+ => Palette n+ -> [(FuncLang, String)]+ -> ConnectionPoint+ -> Context -- context to connect+ -> Context -- context to erase+ -> FuncLang -- term to translate+ -> Network g n e -> Network g n e+simpleRHS palette names point goodCtx eraCtx term = -- trace ("simpleRHS: POINT: " ++ show point ++ " GOODCTX" ++ show (Map.keys goodCtx) ++ " ERACTX: " ++ show (Map.keys eraCtx) ++" TERM: " ++ show term ) $+ iso palette names point (2,0) term goodCtx+ . closeEpsilon palette eraCtx+++-- | Defines a RHS with one recursive call.+-- Like IterNat |X| suc or IterList |X| cons+oneRecursiveCallRHS :: (InfoKind n g, InfoKind e g)+ => Palette n+ -> [(FuncLang, String)]+ -> ConnectionPoint -- (token, arg) port to connect generated net+ -> Context -- context to connect to copy+ -> Context -- context to pass to translate function; refers to arguments of constructor+ -> Context -- context to connect to iterator+ -> ConnectionPoint -- interface for place to apply recursion+ -> Variable -- variable that represents result of recursive call+ -> FuncLang -- term to translate+ -> String -- Iterator agent name+ -> Char -- port prefix for final elements+ -> Char -- port prefix for cont elements+ -> Network g n e -> Network g n e+oneRecursiveCallRHS palette names topPoint copyCtx argCtx stopCtx argPoint var term iterAgent pF pC net =+ let (newNet, newCtx) =+ if var `elem` lFreeVars+ then+ let+ (iterNr,net1) = addNode iterAgent palette net -- add iter agent+ (net2, ctxNew) = Map.mapAccumWithKey (connectCopies iterNr) net1 copyCtx -- (Iter, FV(S)) |-> (copy, snd_target)+ -- (copy, src) |-> copyCtx+ in ( connectNodes palette (iterNr,iterAgent,"arg") argPoint -- (Iter, arg) |-> argInterface+ . connectPorts palette pF iterNr iterAgent stopCtx -- (Iter, FV(Z)) |-> stopCtx+ . moveNode iterNr (0,-1) argPoint+ $ net2, Map.insert var (iterNr,iterAgent,"res") ctxNew )++ else (closeEpsilon palette (Map.insert "" argPoint stopCtx) net, copyCtx)+ (frees, dontExist) = Map.partitionWithKey aux argCtx++ in iso palette names topPoint (2,0.7) term (frees `Map.union` newCtx)+ . closeEpsilon palette dontExist+ $ newNet+ where+ lFreeVars = freeVars term++-- connectCopies :: NodeNr -> Network g n e -> Variable -> ConnectionPoint -> (Network g n e, ConnectionPoint)+ connectCopies iterNr net var point =+ let (copyNr,net1) = addNode "copy" palette net+ in (connectNodes palette (iterNr,iterAgent,pC:'_':var) (copyNr,"copy","snd_target")+ . connectNodes palette (copyNr,"copy","src") point+ . moveNode copyNr (0,-0.8) point+ $ net1, (copyNr,"copy","fst_target") )++ aux var _ = var `elem` lFreeVars++type ConnectionPoint = ( NodeNr+ , ShapeName+ , PortName+ )++-- | Connect a port in a node to another.+connectNodes :: (InfoKind e g) => Palette n -> ConnectionPoint -> ConnectionPoint -> Network g n e -> Network g n e+connectNodes palette (nrFrom, shapeFrom, portFrom) (nrTo, shapeTo, portTo) net =+ case (getNodeShape net nrFrom, getNodeShape net nrTo) of+ (str1, str2) | str1 == shapeFrom && str2 == shapeTo ->+ case (getPorts palette net nrFrom, getPorts palette net nrTo) of+ (Just portsFrom, Just portsTo) ->+ case (Data.List.lookup portFrom portsFrom, Data.List.lookup portTo portsTo) of+ (Just _, Just _) ->+ addEdge palette nrFrom portFrom nrTo portTo net+ (Nothing,_) -> error $ "Port \"" ++ portFrom ++ "\" do not exist in symbol \"" ++ shapeFrom ++ "\"."+ (_,Nothing) -> error $ "Port \"" ++ portTo ++ "\" do not exist in symbol \"" ++ shapeTo ++ "\"."+ _ -> error "No ports."+ _ -> error "Shapes do not coincide."++-- | Move first node to position @(dx,dy)@ relatively to reference point position.+moveNode :: NodeNr -> (Double,Double) -> ConnectionPoint -> Network g n e -> Network g n e+moveNode node (dx,dy) refPoint net =+ setNodePosition node ( translate (DoublePoint dx dy)+ $ getNodePosition net $ fst3 refPoint)+ net+
+ src/Functional/Language.hs view
@@ -0,0 +1,204 @@+{-|+ Module : Functional.Language+ Copyright : (c) Miguel Vilaça 2007++ Maintainer : jmvilaca@di.uminho.pt+ Stability : experimental+ Portability : portable+++ Small Functional Language++-}+module Functional.Language where++import Data.List++import Common+++type Variable = String++data CallBy = Value | Name | Need deriving (Eq, Show)++data FuncLang = Var Variable -- 1 (precedences)+ | Abst Variable FuncLang -- 7+ | Appl FuncLang FuncLang -- 10+ | TT -- 1+ | FF -- 1+ | IterBool FuncLang FuncLang FuncLang -- 5+ | Zero -- 1+ | Succ FuncLang -- 3+ | IterNat Variable FuncLang FuncLang FuncLang -- 5+ | Nil -- 1+ | Cons FuncLang FuncLang -- 3+ | IterList Variable Variable FuncLang FuncLang FuncLang -- 5+ deriving (Eq)++-- | Default names and expressions for 'FuncLang' terms.+listLangConstructors :: [(String, FuncLang)]+listLangConstructors =+ [ ("Abstraction" , Abst "x" (Var "t"))+ , ("Application" , Appl (Var "t") (Var "u"))+ , ("True" , TT)+ , ("False" , FF)+ , ("If then else" , IterBool (Var "V") (Var "F") (Var "b"))+ , ("0" , Zero)+ , ("successor" , Succ (Var "t"))+ , ("Nat iterator" , IterNat "x" (Var "S") (Var "Z") (Var "t"))+ , ("[]" , Nil)+ , (":" , Cons (Var "H") (Var "T"))+ , ("List iterator", IterList "x" "y" (Var "C") (Var "N") (Var "t"))+ ]++instance Show FuncLang where+ -- precedence 9 is a special one; means that it is inside an abstraction+ showsPrec 9 (Abst v t) =+ showChar ','+ . showString v+ . showsPrec 9 t+ showsPrec 9 x = showChar ']' . showsPrec 0 x+ showsPrec d (Abst v t) =+ showParen (d > 7) $+ showChar '['+ . showString v+ . showsPrec 9 t+ -- elements of precedence 1; those never surrounded by parenthesis+ showsPrec _ (Var x) = showString x+ showsPrec _ TT = showString "tt"+ showsPrec _ FF = showString "ff"+ showsPrec _ Zero = showString "0"+ showsPrec _ Nil = showString "nil"+ -- elements of precedence 3+ showsPrec _ (Succ n) =+ showString "suc("+ . showsPrec 0 n+ . showChar ')'+ showsPrec _ (Cons h t) =+ showString "cons("+ . showsPrec 0 h+ . showChar ','+ . showsPrec 0 t+ . showChar ')'+ -- elements of precedence 5+ showsPrec _ (IterBool v f b) =+ showString "iterbool("+ . showsPrec 0 v+ . showChar ','+ . showsPrec 0 f+ . showChar ','+ . showsPrec 0 b+ . showChar ')'+ showsPrec _ (IterNat x s z n) =+ showString "iternat("+ . showsPrec 0 (Abst x s)+ . showChar ','+ . showsPrec 0 z+ . showChar ','+ . showsPrec 0 n+ . showChar ')'+ showsPrec _ (IterList h t c n l) =+ showString "iterlist("+ . showsPrec 0 (Abst h $ Abst t c)+ . showChar ','+ . showsPrec 0 n+ . showChar ','+ . showsPrec 0 l+ . showChar ')'+ -- elements of precedence 10+ showsPrec d (Appl u v) =+ showParen (d > 10) $+ showsPrec 11 u+ . showChar ' '+ . showsPrec 11 v++-- | Show iter_TYPE symbols.+showAgent :: FuncLang -> String+showAgent t@(IterBool v f (Var "")) = show t+showAgent t@(IterNat x s z (Var "")) = show t+showAgent t@(IterList h r c n (Var "")) = show t+showAgent _ = error "unexpected functional term here"++cata :: (Variable -> r) -- ^ Var+ -> (Variable -> r -> r) -- ^ Abstraction+ -> (r -> r -> r) -- ^ Application+ -> r -- ^ True+ -> r -- ^ False+ -> (r -> r -> r -> r) -- ^ IterBool+ -> r -- ^ Zero+ -> (r -> r) -- ^ Succ+ -> (Variable -> r -> r -> r -> r) -- ^ IterNat+ -> r -- ^ Nil+ -> (r -> r -> r) -- ^ Cons+ -> (Variable -> Variable -> r -> r -> r -> r) -- ^ IterList+ -> FuncLang -- ^ term+ -> r -- ^ result+cata fVar fAbst fAppl fTT fFF fIB fZ fS fIN fN fC fIL = cata'+ where cata' term =+ case term of+ Var var -> fVar var+ Abst var t -> fAbst var (cata' t)+ Appl t1 t2 -> fAppl (cata' t1) (cata' t2)+ TT -> fTT+ FF -> fFF+ IterBool t1 t2 t3 -> fIB (cata' t1) (cata' t2) (cata' t3)+ Zero -> fZ+ Succ t -> fS (cata' t)+ IterNat var t1 t2 t3 -> fIN var (cata' t1) (cata' t2) (cata' t3)+ Nil -> fN+ Cons t1 t2 -> fC (cata' t1) (cata' t2)+ IterList var1 var2 t1 t2 t3 -> fIL var1 var2 (cata' t1) (cata' t2) (cata' t3)++-- | Dummy variable+eVar = Var ""++-- | Collect all the symbols in a term.+-- The possible symbols are:+-- * @ IterBool t1 t2 (Var \"\") @+-- * @ IterNat v t1 t2 (Var \"\") @+-- * @ IterList v1 v2 t1 t2 (Var \"\") @+listIteratorSymbols,listSymbs :: FuncLang -> [FuncLang]+listIteratorSymbols = listSymbs++listSymbs term =+ case term of+ Var _var -> []+ Abst _var t -> listSymbs t+ Appl t1 t2 -> (listSymbs t1) `join` (listSymbs t2)+ TT -> []+ FF -> []+ IterBool t1 t2 t3 -> [IterBool t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)+ Zero -> []+ Succ t -> listSymbs t+ IterNat var t1 t2 t3 -> [IterNat var t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)+ Nil -> []+ Cons t1 t2 -> (listSymbs t1) `join` (listSymbs t2)+ IterList var1 var2 t1 t2 t3 -> [IterList var1 var2 t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)+ where join = union++-- | Give some sequential names to symbols.+giveNames :: [FuncLang] -> [(FuncLang, String)]+giveNames = snd . mapAccumL f 1+ where f acc x = (acc+1,(x,"Iter_" ++ show acc))+++-- | List the free variables of a term; the result is a set.+freeVars :: FuncLang -> [String]+freeVars = cata singleton delete union [] [] fIB [] id fIN [] union fIL+ where+ fIB r1 r2 r3 = r1 `union` r2 `union` r3+ fIN v r1 r2 r3 = (delete v r1) `union` r2 `union` r3+ fIL x y r1 r2 r3 = ( r1\\[x,y] ) `union` r2 `union` r3++-- | Special lookup function for iterators with an equality.+lookupIterName :: FuncLang -> [(FuncLang, String)] -> Maybe String+lookupIterName term [] = Nothing+lookupIterName term ((term2,str):xs) | term `equal` term2 = Just str+ | otherwise = lookupIterName term xs+ where+ equal :: FuncLang -> FuncLang -> Bool+ equal (IterBool v1 f1 _) (IterBool v2 f2 _) = v1==v2 && f1==f2+ equal (IterNat x1 s1 z1 _) (IterNat x2 s2 z2 _) = x1==x2 && s1==s2 && z1==z2+ equal (IterList x1 y1 c1 n1 _) (IterList x2 y2 c2 n2 _) = x1==x2 && y1==y2 && c1==c2 && n1==n2+ equal _ _ = False+
+ src/Functional/Parser.hs view
@@ -0,0 +1,145 @@+{-|+ Module : Functional.Parser+ Copyright : (c) Miguel Vilaça 2007++ Maintainer : jmvilaca@di.uminho.pt+ Stability : experimental+ Portability : portable+++ Small Functional Language: Parser++-}+module Functional.Parser (parse) where++import Functional.Language+import Data.Char+++parse :: String -> Either FuncLang String+parse str =+ case filter (nul.snd) res of+ [(term, _)] -> Left term+ _ -> case res of+ [] -> Right "Null result"+ l -> Right $ "Ambiguous parsing.\n" ++ show l+ where res = reads $ map f str+ f c | isControl c = ' '+ | otherwise = c+ nul = all (\c -> isControl c || isSpace c)++instance Read FuncLang where+-- readsPrec :: Int -> String -> [(a, String)]+ readsPrec d str =+ map (\(v,s) -> (Var v,s)) (readVar str) -- variables+ ++ readParen (d > abst_prec) -- abstraction - allow [x,y]t+ (\r -> [(vs t, r4) |+ ("[",r2) <- lex r,+ (vs,r3) <- readVars r2,+ (t,r4) <- readsPrec (abst_prec+1) r3 ]) str+ ++ readParen (d > app_prec)+ (\r -> [(Appl t u, r2) |+ (t,r1) <- readsPrec (app_prec+1) r,+ (u,r2) <- readsPrec (app_prec+1) r1 ]) str+ ++ readTerminal TT "tt" str+ ++ readTerminal FF "ff" str+ ++ readParen (d > iter_prec) -- iterbool+ (\r -> [(IterBool v f b, r8) |+ ("iterbool",r1) <- lex r,+ ("(",r2) <- lex r1,+ (v,r3) <- readsPrec 0 r2,+ (",",r4) <- lex r3,+ (f,r5) <- readsPrec 0 r4,+ (",",r6) <- lex r5,+ (b,r7) <- readsPrec 0 r6,+ (")",r8) <- lex r7]) str+ ++ readTerminal Zero "0" str+ ++ readParen (d > const_prec) -- suc+ (\r -> [(Succ m, r4) |+ ("suc",r1) <- lex r,+ ("(",r2) <- lex r1,+ (m,r3) <- readsPrec 0 r2,+ (")",r4) <- lex r3]) str+ ++ readParen (d > iter_prec) -- iternat+ (\r -> [(IterNat x s z t, r8) |+ ("iternat",r1) <- lex r,+ ("(",r2) <- lex r1,+ (Abst x s,r3) <- readsPrec 0 r2,+ (",",r4) <- lex r3,+ (z,r5) <- readsPrec 0 r4,+ (",",r6) <- lex r5,+ (t,r7) <- readsPrec 0 r6,+ (")",r8) <- lex r7]) str+ ++ readTerminal Nil "nil" str+ ++ readParen (d > const_prec) -- cons+ (\r -> [(Cons a as, r6) |+ ("cons(",r1) <- lex r,+ ("(",r2) <- lex r1,+ (a,r3) <- readsPrec 0 r2,+ (",",r4) <- lex r3,+ (as,r5) <- readsPrec 0 r4,+ (")",r6) <- lex r5]) str+ ++ readParen (d > iter_prec) -- iterlist+ (\r -> [(IterList x y c n l, r8) |+ ("iterlist",r1) <- lex r,+ ("(",r2) <- lex r1,+ (Abst x (Abst y c),r3) <- readsPrec 0 r2,+ (",",r4) <- lex r3,+ (n,r5) <- readsPrec 0 r4,+ (",",r6) <- lex r5,+ (l,r7) <- readsPrec 0 r6,+ (")",r8) <- lex r7]) str+ where+ abst_prec = 5+ app_prec = 5+ terminal_prec = 10+ iter_prec = 10+ const_prec = 10+ readTerminal term symb str =+ readParen (d > terminal_prec)+ (\r -> [(term,t) |+ (symb1,t) <- lex r, symb1 == symb]) str+ readVar str =+ readParen False+ (\r -> [(v,t) |+ (v,t) <- lex r, isVariable v]) str+ readVars str =+ [ (Abst v, r1) | (v,r) <- readVar str+ , ("]",r1) <- lex r]+ +++ [ (Abst v . lv, r2)+ | (v,r) <- readVar str+ , (",",r1) <- lex r+ , (lv, r2) <- readVars r1]++reservedWords :: [String]+reservedWords = ["tt","ff","iterbool","0","suc","iternat","nil","cons","iterlist"]++isVariable :: String -> Bool+isVariable str =+ not (null str)+ && str `notElem` reservedWords+ && all isAlphaNum str+ && not (isDigit $ head str)+++-- Examples++str = " [x,y,z,a,b]("+ ++ "(iterbool(x,y,tt) iterlist([x,y]y (x (a z)), (a z), nil) )"+ ++ "(iternat([x]x,x,0) iterbool(y,y,tt)))"++term = Left $ Abst "x" $ Abst "y" $ Abst "z" $ Abst "a" $ Abst "b" $+ Appl+ (Appl (IterBool x y TT)+ (IterList "x" "y" (Appl y $ Appl x $ Appl a z) (Appl a z) Nil)+ )+ (Appl (IterNat "x" x x Zero)+ (IterBool y y TT)+ )++x = Var "x"+y = Var "y"+z = Var "z"+a = Var "a"+
+ src/Functional/UI.hs view
@@ -0,0 +1,226 @@+{-|+ Module : Functional.UI+ Copyright : (c) Miguel Vilaça and Daniel Mendes 2007++ Maintainer : jmvilaca@di.uminho.pt and danielgomesmendes@gmail.com+ Stability : experimental+ Portability : portable+++ Small Functional Language: Graphical stuff for integration in INblobs.++-}+module Functional.UI+ ( compileUI+ ) where++import State+import StateUtil+import qualified PersistentDocument as PD+import Common+import CommonIO+import CommonUI+import InfoKind+import Text.XML.HaXml.XmlContent (XmlContent)++import Graphics.UI.WX+import Graphics.UI.WXCore++import Functional.Language+import Functional.Parser+import Functional.Compiler++import Data.List+import Data.Char+import qualified Control.Exception as E+++-- | List of strategies for which compilation is available.+listCallBy :: [CallBy]+listCallBy = [ Name, Value ]++-- | GUI for compilation of BNL to INs.+compileUI :: (InfoKind n g, InfoKind e g, XmlContent g) => State g n e -> g -> n -> e -> IO ()+compileUI state g n e =+ closeDocAndThen state $+ do+ theFrame <- getNetworkFrame state++ res <- parseDialog theFrame+ case res of+ Nothing -> return ()+ Just (term, callBy)+ |not . null $ freeVars term ->+ errorDialog theFrame "Free variables"+ $ "Only closed terms are allowed and this one have the following free vars:\n" ++ commasAnd (freeVars term)+ Just (term, callBy) ->+ do+ let iterSymbs = listIteratorSymbols term+ names <- if null iterSymbs+ then return (Just [])+ else meaningfulNamesDialog iterSymbs theFrame+ case names of+ Nothing -> return ()+ Just names ->+ flip E.catch (\exception ->+ do+ logMessage "END COMPILATION BADLY"+ wxcEndBusyCursor+ errorDialog theFrame "Compilation failed..." (show exception)+ ) $+ do+ -- loadDocument+ let fname = "examples/New-Token-Passing/CallBy"+ ++ show callBy +++ "ForClosedTerms+BNL-Iterators.INblobs"+ openNetworkFile fname state (Just theFrame)+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ wxcBeginBusyCursor+ logMessage "COMPILING..."+ doc2 <- compile g n e callBy term names doc+ logMessage "END COMPILATION SUCCESSFULLY"+ wxcEndBusyCursor+ let fname2 = "examples/New-Token-Passing/GENERATED-CallBy"+ ++ show callBy +++ "ForClosedTerms+BNL-Iterators.INblobs"+ PD.resetDocument (Just fname2) doc2 pDoc++ -- Redraw+ applyCanvasSize state+ buildVisiblePalette state+ reAddRules2Tree state+ repaintAll state++-- | Deal with collecting a term from the user.+-- Graphical treatment of parsing errors is done here.+parseDialog :: Frame () -> IO (Maybe (FuncLang,CallBy))+parseDialog theFrame =+ do+ dial <- dialog theFrame [text := "Functional term to IN system", position := pt 200 20]+ p <- panel dial []+ termbox <- textCtrlRich p [text := ""]+ help <- button p+ [ text := "Help"+ , on command := infoDialog dial "Help" helpString+ ]++ okB <- button p [ text := "Ok" ]+ canB <- button p [ text := "Cancel" ]++ -- one button per functional language constructor+ listBs <- mapM (\(name,term) -> button p+ [ text := name+ , on command := addTxtInPlace2TextCtrl termbox $ show term+ ])+ listLangConstructors++ -- CallByX+ when (null listCallBy) (error "No strategies available.")+ callByUI <- radioBox p Vertical (map show listCallBy)+ [ text := "Which evaluation strategy?"+ , selection := 0+ ]++ errorsUI <- textCtrl p [ visible := False ]++ set dial [ layout := container p $+ margin 10 $+ column 5 [ label "Input your term:"+ , row 2 [ hfill $ widget termbox+ , column 10 (map widget listBs)+ ]+ , widget callByUI+ , minsize (sz 30 30) . fill $ widget errorsUI+ , widget help+ , hrule 350+ , floatRight $ row 5 [widget okB, widget canB]+ ]+ ]++ showModal dial $ \stop ->+ do+ set canB [on command := stop Nothing]+ set okB [on command :=+ do+ set errorsUI [ visible := False, text := ""]+ txt <- get termbox text+ i <- get callByUI selection++ case parse txt of+ Left term -> stop $ Just (term, listCallBy !! i)+ Right errMsg ->+ do+ set errorsUI [ visible := True+ , text := "Parse error:\n" ++ errMsg+ ]+ errorDialog theFrame "Parsing Error" "Parsing error.\nSee report."+ ]++ where helpString = "Use the buttons on the right side to create a term or write it if already familiar with the syntax."++-- | Allow the user to supply more meaningful names for symbols that correspond to iterators with internalized arguments.+-- Checks if:+-- * given names don't contain blank or control characters+-- * given names are disjoint+meaningfulNamesDialog :: [FuncLang] -> Frame () -> IO (Maybe [(FuncLang, String)])+meaningfulNamesDialog terms theFrame =+ do+ dial <- dialog theFrame [text := "Meaningful names"+ , position := pt 200 20+ , resizeable := True+ ]+ p <- panel dial []++ listG <- listCtrl p [ columns := [ ("Symbol name", AlignRight, -1)+ , ("Term", AlignLeft, 200)+ ]+ , items := [[name, showAgent term] | (term, name) <- giveNames terms]+ , style :~ (wxLC_EDIT_LABELS .+. wxLC_VRULES .+.)+ ]++ okB <- button p [ text := "Ok" ]+ canB <- button p [ text := "Cancel" ]++ errorsUI <- textCtrl p [ visible := False ]++ set dial [ layout := container p $+ margin 10 $+ column 5 [ label "Edit the \"Symbol name\" column to give more meaningful names."+ , fill $ widget listG+ , fill $ widget errorsUI+ , hrule 350+ , floatRight $ row 5 [widget okB, widget canB]+ ]+ ]++ showModal dial $ \stop ->+ do set okB [ on command :=+ do+ newNames <- get listG items+ let mapp = zip terms (map head newNames)+ -- Check that given names are good names.+ badNames = filter (badName . snd) mapp+ -- Check that given names are disjoint.+ equalNames = filter ((> 1) . length)+ $ groupBy (\(_,a) (_,b) -> a == b) mapp+ case (null badNames, null equalNames) of+ (True, True) -> stop $ Just mapp+ (False, _) -> -- some bad names+ set errorsUI [ visible := True+ , text := "The symbol's name(s) for the following term(s) contain invalid (control or blank) characters:\n"+ ++ (indent 1 . unlines) (map (showAgent . fst) badNames)+ ]+ (True, False) -> -- repeated names+ set errorsUI [ visible := True+ , text := "The following terms have the same name(s):\n "+ ++ beautify equalNames+ ]+ ]+ set canB [on command := stop Nothing]+ where+ beautify :: [[(FuncLang,String)]] -> String+ beautify = unlines . map (\l -> snd (head l) ++ "\n"+ ++ indent 1 (unlines $ map (showAgent.fst) l))+ badName = any (\c -> isSpace c || isControl c)+
+ src/GUIEvents.hs view
@@ -0,0 +1,243 @@+module GUIEvents where++import Data.List (nub,(\\))+import NetworkView(clickedNode, clickedNodePort, clickedEdge, clickedVia)+import NetworkControl+import State+import Ports+import Common+import CommonIO+import Document+import qualified ContextMenu+import qualified PersistentDocument as PD+import InfoKind+import Text.Parse+import INReduction+import INReductionStrategies++import Graphics.UI.WX+import Graphics.UI.WXCore++mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g) =>+ Bool -> Point -> Frame () -> State g n e -> IO ()+mouseDown leftButton mousePoint theFrame state =+ do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; doc <- PD.getDocument pDoc+ ; ppi <- getScreenPPI+ ; let network = selectNetwork doc canvas + doubleMousePoint = screenToLogicalPoint ppi mousePoint++ ; disableReduce state++ ; case clickedNodePort doubleMousePoint doc canvas of+ Nothing ->+ case clickedVia doubleMousePoint network of+ Nothing ->+ case clickedEdge doubleMousePoint network of+ Nothing -> -- click in empty area+ if leftButton then+ pickupArea doubleMousePoint state+ else ContextMenu.canvas theFrame state+ Just edgeNr -> -- click over the edge edgeNr++ do let toReduce = canvas == Net && isActivePair edgeNr (getPalette doc) network+ when toReduce $+ do button <- getReduceButton state+ set button [enabled := True]++ if leftButton then+ selectEdge edgeNr state+ else+ do{ selectEdge edgeNr state+ ; ContextMenu.edge theFrame doubleMousePoint state toReduce+ }+ Just (edgeNr,viaNr) -> -- click over the via viaNr on edge edgeNr+ if leftButton then+ case getSelection doc of+ MultipleSelection canv _ ns vs+ | (edgeNr,viaNr) `elem` vs && canv == canvas ->+ pickupMultiple ns vs doubleMousePoint state+ _ -> pickupVia edgeNr viaNr doubleMousePoint state+ else+ do{ selectVia edgeNr viaNr state+ ; ContextMenu.via theFrame state+ }+ Just (nodeNr, mPort) -> -- click over node nodeNr and + -- if also click on a port of that node mPort will be+ -- Just port or + -- Nothing if click over a node but none of its ports+ if leftButton then+ case getSelection doc of+ MultipleSelection canv _ ns vs + | nodeNr `elem` ns && canv == canvas ->+ pickupMultiple ns vs doubleMousePoint state+ _ -> pickupNode nodeNr mPort doubleMousePoint state+ else+ do{ selectPort nodeNr mPort state+ ; ContextMenu.node nodeNr theFrame state+ }+ }++leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) =>+ Point -> State g n e -> IO ()+leftMouseDownWithShift mousePoint state =+ do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; doc <- PD.getDocument pDoc+ ; ppi <- getScreenPPI+ ; let network = selectNetwork doc canvas + doubleMousePoint = screenToLogicalPoint ppi mousePoint++ ; disableReduce state++ ; case clickedNodePort doubleMousePoint doc canvas of+ Nothing ->+ case clickedEdge doubleMousePoint network of+ Nothing ->+ -- shift click in empty area = create new node+ createNode doubleMousePoint state -- change shape of new node+ Just i ->+ selectEdge i state -- shift click on edge = select+ Just (j,mP) -> do -- shift click on node = create edge (if possible) + case (getSelection doc, mP, canvas) of+ (NodeSelection canv i (Just p), Just p', canvas) + | canv==canvas -> createEdge i p j p' state+ (NodeSelection (LHS rL) i (Just p), Just p', RHS rR) + | rL==rR && p == p' && isInterfacePort p+ -> createMapping rL i j state+ -- print ("CREATING MAP: ", rL, (i, mPL), (nNrR, mPR))++{-+ (NodeSelection canv i Nothing, Nothing, canvas) | i /= j -- no edges from one node to it self+ -> if hasPorts then logMessage "Only allow connections between ports." else ?? -- createEdge i j state + (NodeSelection canv i Nothing, Just p') -> logMessage "Repeat it selecting a source port."+ (NodeSelection canv i (Just p),Nothing) -> logMessage "Select a destination port."+ (NodeSelection canv i (Just p), Just p') | i /= j -> createEdgePorts i p j p' state+-} + _ -> selectPort j mP state+ } ++-- para mudar+leftMouseDownWithMeta :: (InfoKind n g, InfoKind e g) =>+ Point -> State g n e -> IO ()+leftMouseDownWithMeta mousePoint state =+ do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; doc <- PD.getDocument pDoc+ ; ppi <- getScreenPPI+ ; let network = selectNetwork doc canvas + doubleMousePoint = screenToLogicalPoint ppi mousePoint++ ; disableReduce state++ ; case clickedNode doubleMousePoint doc canvas of++ Just j -> do -- meta click on node = toggle whether node in selection+ case getSelection doc of+ NodeSelection _ i _ {-??-}+ | i == j -> selectNothing state+ | i /= j -> selectMultiple Nothing (nub [i,j]) [] state+ ViaSelection _ e v -> selectMultiple Nothing [j] [(e,v)] state+ MultipleSelection _ _ ns vs+ | j `elem` ns -> selectMultiple Nothing (ns\\[j]) vs state+ | otherwise -> selectMultiple Nothing (j:ns) vs state+ _ -> selectNode j state+ Nothing ->+ case clickedVia doubleMousePoint network of+ Just via@(e,v) -> -- meta click on via point = toggle inclusion+ case getSelection doc of+ NodeSelection _ i _ {-??-} -> selectMultiple Nothing [i] [(e,v)] state+ ViaSelection _ e' v'+ | e==e' && v==v' -> selectNothing state+ | otherwise -> selectMultiple Nothing [] [via,(e',v')]+ state+ MultipleSelection _ _ ns vs+ | via `elem` vs -> selectMultiple Nothing ns (vs\\[via])+ state+ | otherwise -> selectMultiple Nothing ns (via:vs) state+ _ -> selectVia e v state+ Nothing -> return ()+ }++leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO ()+leftMouseDrag mousePoint _ state =+ do{ dragging <- getDragging state+ ; ppi <- getScreenPPI+ ; ifJust dragging $ \_ ->+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas ->+ dragNode nodeNr doubleMousePoint state+ ViaSelection canv edgeNr viaNr | canv == canvas ->+ dragVia edgeNr viaNr doubleMousePoint state+ MultipleSelection canv Nothing ns vs | canv == canvas ->+ dragMultiple ns vs doubleMousePoint state+ MultipleSelection canv _ _ _ | canv == canvas ->+ dragArea doubleMousePoint state+ _ -> do selectNothing state+ -- setDragging Nothing state+ }+ }++leftMouseUp :: Point -> State g n e -> IO ()+leftMouseUp mousePoint state =+ do{ dragging <- getDragging state+ ; ppi <- getScreenPPI+ ; ifJust dragging $ \(hasMoved, offset) ->+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas ->+ dropNode hasMoved nodeNr offset doubleMousePoint state+ ViaSelection canv edgeNr viaNr | canv == canvas ->+ dropVia hasMoved edgeNr viaNr offset doubleMousePoint state+ MultipleSelection canv Nothing ns vs | canv == canvas ->+ dropMultiple hasMoved ns vs offset doubleMousePoint state+ MultipleSelection canv _ _ _ | canv == canvas->+ dropArea offset doubleMousePoint state+ _ -> do selectNothing state+ -- setDragging Nothing state+ -- return ()+ }+ }++deleteKey :: State g n e -> IO ()+deleteKey state =+ do disableReduce state+ deleteSelection state++backspaceKey :: State g n e -> IO ()+backspaceKey state =+ do disableReduce state+ deleteSelection state++f2Key :: Frame () -> State g n e -> IO () -- due for demolition+f2Key theFrame state =+ do disableReduce state+ renameNode theFrame state++pressRKey :: Frame () -> State g n e -> IO ()+pressRKey theFrame state =+ do disableReduce state+ renameNode theFrame state++pressIKey :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO ()+pressIKey theFrame state =+ do disableReduce state+ reinfoNodeOrEdge theFrame state++upKey :: State g n e -> IO ()+upKey state =+ do disableReduce state+ changeNamePosition True state++downKey :: State g n e -> IO ()+downKey state =+ do disableReduce state+ changeNamePosition False state
+ src/INChecks.hs view
@@ -0,0 +1,519 @@+{- | To create new Checks simply:++ 1. create an element of type 'Check g n e'++ 2. add it to the list 'checksList'++ If necessary create new 'INError' values and+ extend the 'show' function definition.+-}+module INChecks+ (+ -- * Data-types+ INError(..)+ , ErrorLoc+ , CheckOp+ , Check++ -- * List of available check operations+ , checksList++ , iNCheck++ -- * Check operations combinators+ , join+ , joins++ -- * Other functions useful elsewhere+ , undefinedAgents+ ) where++import Document+import Network+import Ports+import INRule+import Palette hiding (join)+import Common+import Shape+import SpecialSymbols++import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List++-- | Interaction Nets Errors+data INError g n e+ = DisconnectedPorts [(NodeNr, Node n, [Port])] -- ^ Disconnected ports+ | ErrorString String -- ^ General error+ | MultiDef String Int -- ^ Symbol is defined multiple times in palette+ | UndefAgent (Node n) -- ^ Undefined agent+ | BadInterfaceSymbol Shape Ports -- ^ Bad interface symbol definition+ | BadInterfaceAgent (Node n) -- ^ Bad interface agent+ | SymbolNoPorts String -- ^ Symbol without ports+ | SymbolRepeatedPorts String [(String, Int)] -- ^ Symbol with repeated port names+ | SymbolDiffPorts String Ports Ports -- ^ Symbol definition differ from default one.+ | AgentNoPorts (Node n) -- ^ Agent without ports+ | MappingNoDom Mapping NodeNr -- ^ Bad mapping which refers one element in domain that do not exist.+ | MappingNoRang Mapping NodeNr -- ^ Bad mapping which refers one element in range that do not exist.+ | MappingNotInj Mapping NodeNr -- ^ Mapping is not injective with respect to LHS node given.+ | MappingNotFunc Mapping NodeNr -- ^ Mapping is not a function with respect to RHS node given.+ | UnMappedInterface (Node n) -- ^ Interface agent is not mapped to another.+ | Not2Agents [Node n] -- ^ rule LHS don't have exactly 2 agents.+ | NoActivePair (Node n) (Node n) -- ^ No active pair between the nodes given+ | ExtraEdge EdgeNr (NodeNr, PortName) (NodeNr, PortName) -- ^ Edge other than edge between principal ports found between agents in LHS.+ | InterfaceBadConnected NodeNr (EdgeNr) -- ^ Interface agent is not connected to free ports of active pair.+ | MultRulesSameLHS String String [String] -- ^ Multiple rules with same LHS active pair, i.e. between shape1 and shape2.++-- | NewError ... -- ^ ++instance (Show g, Show n, Show e) => Show (INError g n e) where+ showsPrec _ (DisconnectedPorts l) =+ showString badPortMsg . showChar '\n' . showString (showBadPortsNet 1 l)+ showsPrec _ (ErrorString str) = showString str+ showsPrec _ (MultiDef symb reps) =+ showString "Symbol \"" . showString symb . showString "\" is defined "+ . shows reps . showString " times in palette of symbols."+ showsPrec _ (UndefAgent node) =+ showString "Agent \"" . showString (Network.getName node)+ . showString "\" @ " . shows (getPosition node)+ . showString " is not defined in the palette of symbols."+ showsPrec _ (BadInterfaceSymbol shape ports) =+ showString ("A symbol called interface is defined, so its definition should be :\n"+ ++ "\tshape = Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 2\n"+ ++ "\t , styleStrokeColour = RGB 255 255 255\n"+ ++ "\t , styleFill = RGB 255 255 255 }\n"+ ++ "\t , shapeRadius = 0.25 }\n"+ ++ "\tports = Just [(\"interface\", DoublePoint 0.0 0.25)]\n"+ ++ "but something different were found:")+ . showString "\tshape = " . shows shape+ . showString "\tports = " . shows ports+ showsPrec _ (BadInterfaceAgent node) =+ showString "Agent \"" . showString (Network.getName node)+ . showString "\" @ " . shows (getPosition node)+ . showString " is a bad interface agent."+ showsPrec _ (SymbolNoPorts symb) =+ showString "Symbol \"" . showString symb . showString "\" don't have ports."+ showsPrec _ (SymbolRepeatedPorts symb reps) =+ showString "Symbol \"" . showString symb . showString "\" have the following repeated port names:\n"+ . showString (unlines $ map showPortRep reps)+ showsPrec _ (SymbolDiffPorts symb ports defaultPorts) =+ showString "Symbol \"" . showString symb . showString "\" is defined with ports \n."+ . shows ports . showString "\nwhich differ from the default definition with ports \n"+ . shows defaultPorts+ showsPrec _ (AgentNoPorts node) =+ showString "Agent \"" . showString (Network.getName node)+ . showString "\" @ " . shows (getPosition node)+ . showString " don't have ports."+ showsPrec _ (MappingNoDom mapping nNr) =+ showString "Interface node " . shows nNr+ . showString " do not exist in LHS but is referred in domain of mapping\n"+ . showsMapping mapping+ showsPrec _ (MappingNoRang mapping nNr) =+ showString "Interface node " . shows nNr+ . showString" do not exist in RHS but is referred in range of mapping\n"+ . showsMapping mapping+ showsPrec _ (MappingNotInj mapping nNr) =+ showString "Mapping is not injective with respect to LHS interface node "+ . shows nNr+ . showChar '\n'+ . showsMapping mapping+ showsPrec _ (MappingNotFunc mapping nNr) =+ showString "Mapping is not a function with respect to RHS interface node "+ . shows nNr+ . showChar '\n'+ . showsMapping mapping+ showsPrec _ (UnMappedInterface node) =+ showString "Interface \"" . showString (Network.getName node)+ . showString "\" @ " . shows (getPosition node)+ . showString " is not mapped to other interface in the other side of the rule."+ showsPrec _ (Not2Agents lNs) =+ showString "The rule LHS should have exactly 2 agents but those "+ . shows (length lNs) . showString " were found:" . showsAgents lNs+ showsPrec _ (NoActivePair node1 node2) =+ showString "No active pair between agent \"" . showString (Network.getName node1)+ . showString "\" @ " . shows (getPosition node1)+ . showString "\nand agent \"" . showString (Network.getName node2)+ . showString "\" @ " . shows (getPosition node2)+ showsPrec _ (ExtraEdge edgeNr (nNr1, port1) (nNr2, port2)) =+ showString "Edge " . shows edgeNr+ . showString "is not the edge between principal ports but also found between agents \"Node "+ . shows nNr1 . showString "\" at port " . showString port1+ . showString " and \"Node " . shows nNr2 . showString "\" at port "+ . showString port2+ showsPrec _ (InterfaceBadConnected nNr edgeNr) =+ showString "Interface \"Node " . shows nNr+ . showString "\" should be connected to one of the free ports of active pair \"Edge "+ . shows edgeNr . showString "\" but it isn't."+ showsPrec _ (MultRulesSameLHS shape1 shape2 rules) =+ showString "There should be at most one rule for pair of agents but for agents \""+ . showString shape1 . showString "\" and \"" . showString shape2+ . showString "\" there are this rules whose LHS is an active pair between such agents :"+ . showString (commasAnd rules)++-- showsPrec _ (NewError ...) = ...++showsAgent :: Node n -> ShowS+showsAgent node =+ showString "Agent \"" . showString (Network.getName node)+ . showString "\" of symbol \""+ . showString (getShape node)+ . showString "\" @ " . shows (getPosition node)+ where err = error ""++showsAgents :: [Node n] -> ShowS+showsAgents [] = showString ""+showsAgents (x:xs) = showsAgent x . showChar '\n' . showsAgents xs++showPortRep :: (PortName, Int) -> String+showPortRep (portname, n) = '\t':portname ++ " ~ " ++ show n ++ " times"++data Side = Lhs | Rhs deriving (Eq,Ord)+instance Show Side where+ show Lhs = "LHS"+ show Rhs = "RHS"++data ErrorLoc = PALETTE | NET | RULES | RULE RuleName (Maybe Side) deriving (Eq, Ord)++instance Show ErrorLoc where+ show PALETTE = "PALETTE"+ show NET = "NET"+ show RULES = "RULES"+ show (RULE ruleName mSide) =+ showString "RULE \"" . showString ruleName . showChar '\"'+ . maybe id (\v -> showChar ' ' . shows v) mSide $ ""+++type CheckOp g n e = Document g n e -> Map ErrorLoc [INError g n e] -- ^ errors by location+type Check g n e =+ ( String -- Check operation name to be displayed+ , String -- Check description+ , String -- Message when the check is passed successfully+ , String -- Message when the check fails+ , CheckOp g n e -- Check function+ )++-- | Join two check operations; concatenate errors.+join :: CheckOp g n e -> CheckOp g n e -> CheckOp g n e+join check1 check2 = uncurry (Map.unionWith (++)) . (check1 /\ check2)++-- | Join a list of check operations.+joins :: [CheckOp g n e] -> CheckOp g n e+joins = foldr1 join++-- | List of available checks.+checksList :: [Check g n e]+checksList =+ [ badPortsCheck+ , iNCheck+ , manCheck+-- , newCheck+ ]++++--------------------------------------------------------+-- | Useful function that transverse a 'Document' in a very common way to collect 'INError's.+doc2Errors :: (Network g n e -> [INError g n e])+ -> (INRule g n e -> [(Maybe Side, [INError g n e])] )+ -> CheckOp g n e+doc2Errors funcNet funcRule =+ uncurry (foldl updtAc)+ . ( (emptyOrSingle NET . funcNet . getNetwork)+ /\+ getRules)+ where+ -- updtAc :: Map ErrorLoc [INError g n e] -> INRule g n e -> Map ErrorLoc [INError g n e]+ updtAc mapp rule = foldl (aux $ INRule.getName rule) mapp $ funcRule rule++ aux :: RuleName -> Map ErrorLoc [INError g n e] -> (Maybe Side, [INError g n e])+ -> Map ErrorLoc [INError g n e]+ aux _ mapp (_,[]) = mapp+ aux ruleName mapp (mSide, errs) = Map.insertWith (++) (RULE ruleName mSide) errs mapp++-- | If the list of values is empty create the empty 'Map'. Else creates the singleton 'map' with key @k@.+emptyOrSingle :: k -> [v] -> Map k [v]+emptyOrSingle k l = if null l then Map.empty else Map.singleton k l++-- Bad Ports ------------------------------------------------------------------------------------------------++badPortMsg = "Disconnected or with multiple connections ports found"++badPortsCheck :: Check g n e+badPortsCheck =+ ( "Check bad ports"+ , "Every port must be connected exactly once."+ , "No disconnected or with multiple connections ports found."+ , badPortMsg+ , pureBadPorts+ )++-- | Every net in INblobs must have exactly one edge connected at each port.+badPortsNet :: Palette n -> Network g n e -> [(NodeNr, Node n, [Port])]+badPortsNet palette network =+ filter f . map badPortsN $ getNodeAssocs network+ where+ f (_,_,t) = not $ null t+ -- Gives list of bad ports for this node.+ badPortsN :: (NodeNr, Node n) -> (NodeNr, Node n, [Port])+ badPortsN (nNr, node) = (nNr, node, case getPorts palette network nNr of+ Nothing -> error $ "Unexpected situation: no ports found in agent "+ ++ show nNr ++ " of type " ++ getShape node+ Just ports -> filter (g nNr . fst) ports)+ g :: NodeNr -> PortName -> Bool+ g nnr port = maybe True (== (nnr,port)) $ otherExtremeOfEdgeConnectedOnPort network nnr port++-- | Collects all bad ports by location.+pureBadPorts :: CheckOp g n e+pureBadPorts doc = doc2Errors funcNet funcRule doc+ where -- funcNet :: Network g n e -> [INError g n e]+ funcNet = insertIfN . badPortsNet palette++ -- funcRule :: INRule g n e -> [(Maybe Side, [INError g n e])]+ funcRule =+ uncurry (++)+ . ((insertIfR Lhs . badPortsNet palette . getLHS)+ /\+ (insertIfR Rhs . badPortsNet palette . getRHS))++ insertIfN netCheck = if null netCheck then [] else [DisconnectedPorts netCheck]+ insertIfR side netCheck = if null netCheck then [] else [(Just side, [DisconnectedPorts netCheck])]++ palette = getPalette doc++showBadPortsNet :: Int -> [(NodeNr, Node n, [Port])] -> String+showBadPortsNet n l = unlines' $ map showNode l+ where showNode (_, node, lPorts) = unlines' $ (replicate n '\t' ++ Network.getName node+ ++ " # " ++ getShape node ++ " @ "+ ++ show (getPosition node) ++ " in port(s):") : map showPort lPorts+ showPort (name,_) = replicate (n+1) '\t' ++ name+------------------------------------------------------------------------------------------------------------------+++-- valid IN system ------------------------------------------------------------------------------------------------+iNCheck :: Check g n e+iNCheck =+ ( "Valid IN system"+ , unlines+ [ "Check if it is a valid IN system.\n"+ , "An IN system is valid in INblobs if:"+ , " * every symbol have distinguished port names"+ , " * every port is connected exactly once in net and in LHS and RHS of every rule"+ , " * the LHS of every rule is one active pair, plus interface agents"+ , " * every interface agent in the LHS (respectively RHS) of a rule is mapped to one interface agent in the RHS (respectively LHS)"+ , " * there are at most one rule per pair of agents"+ , " * every agent mentioned in the net or any rule is declared in the palette of symbols"+ ]+ , "Valid IN system"+ , "Invalid IN system"+ , validIN+ )++{- | An IN system is valid in INblobs if:++ * every symbol have distinguished port names++ * every port is connected exactly once in net and in LHS and RHS of every rule++ * the LHS of every rule is one active pair, plus interface agents++ * every interface agent in the LHS (respectively RHS) of a rule is mapped to+ one interface agent in the RHS (respectively LHS)++ * there are at most one rule per pair of agents++ * every agent mentioned in the net or any rule is declared in the palette of symbols++-}+validIN :: CheckOp g n e+validIN = joins [+ pureBadPorts+ , checkAgents+ , checkEachRule+ , checkNoRepeatedRules+ ]++sepInterface :: Network g n e -> ( [(NodeNr,Node n)] -- interface nodes+ , [(NodeNr,Node n)] -- none interface nodes+ )+sepInterface = partition isInterfaceNode . getNodeAssocs++-- | 'checkLHS' and 'checkMapping'+checkEachRule :: CheckOp g n e+checkEachRule doc = doc2Errors funcNet funcRule doc+ where funcNet :: Network g n e -> [INError g n e]+ funcNet = const []++ -- funcRule :: INRule g n e -> [(Maybe Side, [INError g n e])]+ funcRule rule = (Just Lhs, checkLHS (getPalette doc) lhs)+ : checkMapping (getMapping rule)+ (fst $ sepInterface lhs)+ (fst . sepInterface $ getRHS rule)+ where lhs = getLHS rule++-- | LHS should be exactly two agents different from interface connected trough their+-- principal ports with the rest of the ports connected to one interface agent.+checkLHS :: Palette n -> Network g n e -> [INError g n e]+checkLHS palette = either (const []) id . checkLHS' palette++checkLHS' :: Palette n -> Network g n e -> Either (String, String) [INError g n e]+checkLHS' palette net =+ case sepInterface net of+ (iNs, [(xNr,x), (yNr,y)]) ->+ case (getPorts palette net xNr, getPorts palette net yNr) of+ (Just (px:pxs), Just (py:pys)) ->+ case findEdge xNr (fst px) yNr (fst py) net of+ Nothing -> Right [NoActivePair x y]+ Just ed ->+ let mINs = map (otherExtremeOfEdgeConnectedOnPort net xNr . fst) pxs+ ++ map (otherExtremeOfEdgeConnectedOnPort net yNr . fst) pys+ in if all isJust mINs+ then+ let iNs' = map (id >< const "interface") iNs+ cons = map fromJust mINs+ dif1 = cons \\ iNs' -- multiple edges between agents x and y+ dif2 = iNs' \\ cons -- interface nodes not connected to agent x or y+ in if null dif1 && null dif2+ then Left (getShape x,getShape y)+ else Right $ toError1 dif1 ++ map (toError2 ed) dif2+ else Right [] -- disconnected ports checked in another piece of code++++ (psx, psy) -> Right . map (AgentNoPorts . snd) $ filter (maybe True null . fst) [(psx,x),(psy,y)]+ (_, lAs) -> Right [Not2Agents $ map snd lAs]+ where+ toError1 :: [(NodeNr, PortName)] -> [INError g n e]+ toError1 = map aux3 . groupBy aux2 . map aux+ aux = id /\ fromJust . uncurry (edgeConnectedOnPort net)+ aux2 a b = snd a == snd b+ aux3 :: [((NodeNr,PortName),EdgeNr)] -> INError g n e+ aux3 [(from,edge), (to,_)] = ExtraEdge edge from to+ aux3 _ = error "unexpected situation"+ toError2 ed (nNr,_) = InterfaceBadConnected nNr ed+++-- | Every interface agent in the LHS (respectively RHS) of a rule is mapped to+-- one interface agent in the RHS (respectively LHS).+checkMapping :: Mapping -> [(NodeNr,Node n)] -> [(NodeNr,Node n)] -> [(Maybe Side, [INError g n e])]+checkMapping mapR lhsI rhsI =+ [ (Just Lhs, map errL $ lhs \\ domMap )+ , (Just Rhs, map errR $ rhs \\ rangeMap)+ , (Nothing, (uncurry (++) . (map errNotInj >< map errNoDom ) . partition (`elem` lhs) $ domMap \\ lhs )+ +++ (uncurry (++) . (map errNotFunc >< map errNoRang) . partition (`elem` rhs) $ rangeMap \\ rhs )++ )+ ]+ where+ (domMap, rangeMap) = unzip mapR :: ([NodeNr], [NodeNr])+ lhs = map fst lhsI+ rhs = map fst rhsI++ errL nNr = UnMappedInterface . fromJust $ lookup nNr lhsI+ errR nNr = UnMappedInterface . fromJust $ lookup nNr rhsI+ errNotInj = MappingNotInj mapR+ errNoDom = MappingNoDom mapR+ errNotFunc = MappingNotFunc mapR+ errNoRang = MappingNoRang mapR++insertIf :: Ord k => k -> [a] -> Map k [a] -> Map k [a]+insertIf k a mapp | null a = mapp+ | otherwise = Map.insertWith (++) k a mapp++checkAgents :: CheckOp g n e+checkAgents doc =+ insertIf PALETTE (map toError3 . filter badInterface $ shaps)+ . insertIf PALETTE (map toError4 $ filter repeatedPorts shaps)+ . insertIf PALETTE (map toError2 $ filter noPorts shaps)+ . insertIf PALETTE (map toError . repeateds $ symbs)+ $ undefinedAgents symbs doc+ where+ shaps = shapes $ getPalette doc+ symbs = map fst shaps+ toError (symb, i) = MultiDef symb i+ toError2 = SymbolNoPorts . fst+ toError3 (_, (shape, mPorts, _)) = BadInterfaceSymbol shape mPorts+ toError4 (shapeName, (_, ports, _)) = SymbolRepeatedPorts shapeName . filter ((/=1) . snd) . repeateds $ map fst ports+ noPorts = null . snd3 . snd+ repeatedPorts = haveRepeateds . map fst . snd3 . snd+ fstsnd (a,b,_) = (a,b)++ badInterface ("interface", (_, [("interface",_)], _)) = False+ badInterface ("interface", _) = True+ badInterface _ = False++-- | Check if there are undefined agents.+undefinedAgents :: [String] -> CheckOp g n e+undefinedAgents symbols = doc2Errors funcNet funcRule+ where funcNet :: Network g n e -> [INError g n e]+ funcNet = undefinedAgentNet symbols++ funcRule :: INRule g n e -> [(Maybe Side, [INError g n e])]+ funcRule rule =+ [ (Just Lhs, undefinedAgentNet symbols $ getLHS rule)+ , (Just Rhs, undefinedAgentNet symbols $ getRHS rule)+ ]++undefinedAgentNet :: [String] -> Network g n e -> [INError g n e]+undefinedAgentNet symbols = uncurry (++)+ . ( (map UndefAgent . filter undefs) /\ (map BadInterfaceAgent . filter badInterfaceNode) )+ . getNodes+ where+ undefs = (`notElem` symbols) . getShape+ badInterfaceNode node = (\str -> str == fst interfaceSymbol && not (isInterfaceNode (0,node)) )+ $ getShape node++-- | Checks if there are at most one rule per pair of agents.+checkNoRepeatedRules :: CheckOp g n e+checkNoRepeatedRules doc =+ (\lErrors -> insertIf RULES lErrors Map.empty)+ . map toError . filter dups . groupBy activePair+ . map left . filter isLeft+ . map (INRule.getName /\ checkLHS' (getPalette doc) .getLHS) . getRules+ $ doc+ where+ isLeft = either (const True) (const False) . snd+ left = id >< either id (error "This shouldn't happen")+ activePair :: (RuleName, (String,String)) -> (RuleName, (String,String)) -> Bool+ activePair (_,shapes1) (_,shapes2) = shapes1 == shapes2 || shapes1 == swap shapes2+ dups = (> 1) . length+ toError :: [(RuleName, (String,String))] -> INError g n e+ toError ( (ruleName,(shape1,shape2)):xs) = MultRulesSameLHS shape1 shape2 $ ruleName : map fst xs+------------------------------------------------------------------------------------------------------------------++-- | Checks if declared management agents are defined in the exactly same way that they are in the default palette.+-- Useful to avoid posterior problems with templates.+manCheck :: Check g n e+manCheck =+ ( "Check management agents"+ , "Check if management agents are defined in the exact same way that in 'ManagementAgents.INblobpalette' to avoid troubles with templates."+ , "Management agents definitions match."+ , "Management agent(s) definitions don't match"+ , manCheck'+ )++manCheck' :: CheckOp g n e+manCheck' doc =+ emptyOrSingle PALETTE+ . Map.elems+ . mapMaybeWithKey aux+ . uncurry ( Map.intersectionWith (,) )+ . ( Map.fromList >< Map.fromList )+ $ (shapes $ getPalette doc, shapes specialSymbols)++ where aux :: String -> ((a,Ports,c),(a,Ports,c)) -> Maybe (INError g n e)+ aux k ((_, ports1,_), (_, ports2,_))+ | ports1 == ports2 = Nothing+ | otherwise = Just $ SymbolDiffPorts k ports1 ports2++mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b+-- In GHC 6.6:+-- mapMaybeWithKey = Map.mapMaybeWithKey+-- Allowing retro-compatibility with GHC 6.4+mapMaybeWithKey f = Map.foldWithKey aux Map.empty+ where -- aux :: k -> a -> Map k b -> Map k b+ aux k a = case f k a of+ Nothing -> id+ Just b -> Map.insert k b+
+ src/INChecksUI.hs view
@@ -0,0 +1,257 @@+module INChecksUI+ ( checksList+ , iNCheck+ , singleCheckOverIN+ , checkValidINOnSave+ , multipleChecksOverIN_UI+ , multipleChecksOverINs_UI+ ) where++import INChecks+import State+import qualified PersistentDocument as PD+import Common+import Constants+import Document+import SafetyNet+import DocumentFile+import CommonIO+import InfoKind+import CommonUI++import Text.XML.HaXml.XmlContent (XmlContent)++import Graphics.UI.WXCore hiding (Document)+import Graphics.UI.WX++import Data.Map (Map)+import qualified Data.Map as Map+import Data.List+import Control.Monad+++------------------------------------------------------------------------------------------+showINErrorList :: (Show g, Show n, Show e) => [INError g n e] -> String+showINErrorList = unlines' . map show++showError :: (Show g, Show n, Show e) => Map ErrorLoc [INError g n e] -> String+showError = Map.foldWithKey aux ""+ where -- aux :: ErrorLoc -> [INError g n e] -> String -> String+ aux loc err str = '\t':show loc ++ '\n': indent 2 (showINErrorList err) ++ '\n':str++showError2 :: (Show g, Show n, Show e) => Map ErrorLoc (Map String (String, [INError g n e])) -> String+showError2 = Map.foldWithKey aux2 "" . Map.map (Map.foldWithKey aux "")+ where -- aux :: String -> (String, [INError g n e]) -> String -> String+ aux checkName (badMsg, err) str = checkName ++ " :\n"+ ++ indent 1 (showINErrorList err) ++ '\n':str++ aux2 :: ErrorLoc -> String -> String -> String+ aux2 loc err str = '\t':show loc ++ '\n': indent 2 err ++ '\n':str+++-- | Run the check operation over current IN system.+singleCheckOverIN :: (Show g, Show n, Show e) => Check g n e -> State g n e -> IO ()+singleCheckOverIN (checkName, _, okMsg, badMsg, func) state =+ do w <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ wxcBeginBusyCursor+ let l = func doc+ wxcEndBusyCursor+ if Map.null l+ then infoDialog w (checkName ++ ": Passed") okMsg+ else do logMessage $ badMsg ++ ": \n" ++ showError l+ errorDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.")++-- | Run the \"valid IN\" check operation over current IN system on Save.+checkValidINOnSave :: (Show g, Show n, Show e) => State g n e -> IO a -> IO ()+checkValidINOnSave state action =+ do w <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ wxcBeginBusyCursor+ let l = func doc+ wxcEndBusyCursor+ if Map.null l+ then ignoreResult action+ else do logMessage $ badMsg ++ ": \n" ++ showError l+ go <- proceedDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.\n\nDo you really want to proceed?")+ if go then ignoreResult action else return ()+ where (checkName, _, okMsg, badMsg, func) = iNCheck++-- | Run multiple check operations over current IN system.+multipleChecksOverIN :: (Show g, Show n, Show e) => [Check g n e] -> State g n e -> IO ()+multipleChecksOverIN listChecks state =+ do w <- getNetworkFrame state+ pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ wxcBeginBusyCursor++ case runChecksOver doc listChecks of+ (goodsStr, Nothing) ->+ do+ wxcEndBusyCursor+ infoDialog w "All checks passed" goodsStr+ (goodsStr, Just (badsStr,badsStrLong)) ->+ do+ wxcEndBusyCursor+ logMessage $ goodsStr ++ badsStrLong+ errorDialog w "Checks Failed"+ $ goodsStr ++ badsStr+ ++ "See report in the bottom area."++-- | Runs multiple checks over a document.+runChecksOver :: (Show g, Show n, Show e) =>+ Document g n e -> [Check g n e] -> (String -- good checks+ , Maybe (String -- bad checks+ ,String -- long bag checks report+ ))+runChecksOver doc listChecks =+ if null bads+ then (goodsStr, Nothing)+ else (goodsStr, Just (badsStr, badsStrLong))+ where+ (goods, bads) = partition passed $ map (calc doc) listChecks+ goodsStr = unlines $ map showOK goods+ badsStr = unlines $ map showBAD bads+ badsStrLong = showError2 $ transf bads++ calc doc (a,_,b,c,func) = (a,b,c, func doc)+ passed (_,_,_, r) = Map.null r+ showOK (name,okMsg,_,_) = name ++ ": Passed\n\t" ++ okMsg+ showBAD (name,_,badMsg,_) = name ++ ": Failed\n\t" ++ badMsg+++-- | Change from errors by Check inner sorted by 'ErrorLoc' to errors by 'ErrorLoc', inner sorted by Check.+transf :: [(String, String, String, Map ErrorLoc [INError g n e])] -> Map ErrorLoc (Map String (String, [INError g n e]))+transf = Map.unionsWith Map.union . map aux1+ where aux1 :: (String, String, String, Map ErrorLoc [INError g n e]) -> Map ErrorLoc (Map String (String, [INError g n e]))+ aux1 (name,_, badMsg, mapp) = Map.map (\v -> Map.singleton name (badMsg,v)) mapp+++multipleChecksOverIN_UI :: (Show g, Show n, Show e) => Frame () -> State g n e -> IO ()+multipleChecksOverIN_UI theFrame state =+ do+ mChecks <- chooseChecksDialog theFrame+ case mChecks of+ Nothing -> return ()+ Just [] -> infoDialog theFrame "Zero checks" "Zero checks chosen, so nothing to do"+ Just ks -> multipleChecksOverIN ks state++chooseChecksDialog :: Frame () -> IO (Maybe [Check g n e])+chooseChecksDialog theFrame =+ do+ dialog <- dialog theFrame+ [ text := "Choose Checks"+ ]+ p <- panel dialog []++ lChks <- mapM (\(name, desc,_,_,_) -> checkBox p [ text := name+ , checked := False+ , tooltip := desc+ ]+ ) checksList++ ok <- button p [ text := "Check" ]+ set dialog [ layout := container p $+ margin 10 $+ column 5 [ label "Apply the following checks:"+ , margin 10 . column 5 $ map widget lChks+ , hfloatCentre $ widget ok+ ]+ ]++ showModal dialog $ \stop ->+ do set ok [ on command :=+ do+ sels <- filterM isSelected $ zip lChks checksList+ stop (Just $ map snd sels)+ ]++isSelected = checkBoxGetValue . fst+fst5 (a,_,_,_,_) = a++multipleChecksOverINs_UI :: (InfoKind n g, InfoKind e g, XmlContent g, Show g)+ => State g n e -> IO ()+multipleChecksOverINs_UI state =+ do+ newFrame <- frame [ text := "Multiple Checks Over Multiple INs"+ , size := sz 900 600+ ]+ p <- panel newFrame []+ txt <- textCtrlRich p []+ textCtrlSetEditable txt False+ okB <- button p [ text := "Exit"+ , on command := close newFrame+ ]+ saveB <- button p [ text := "Save to file"+ , on command := safetyNet newFrame $+ do+ mFile <- fileSaveDialog newFrame rememberCurrentDir False "File to save report to:" [("Any file", ["*","*.txt","*.log"])] directory filename+ case mFile of+ Nothing -> errorDialog newFrame "No File" "No file to write to.\n Report not saved."+ Just file -> do str <- textCtrlGetValue txt+ writeFile file str++ ]+ set newFrame [ layout := container p $+ margin 10 $+ column 5 [ fill $ widget txt+ , hfloatRight $ row 5 [widget saveB, widget okB]+ ]+ ]++ files <- filesOpenDialog newFrame rememberCurrentDir allowReadOnly message extensions directory filename+ mlChecks <- chooseChecksDialog newFrame++ case (files, mlChecks) of+ (fs, Just cs) | not (null fs) && not (null cs) -> -- useful case+ do+ textCtrlAppendText txt "Checking ...\n"+ wxcBeginBusyCursor+ mapM_ (reportPerFile state txt cs) fs+ wxcEndBusyCursor+ x -> textCtrlAppendText txt "No files and/or no checks chosen, so nothing to do"++ where+ rememberCurrentDir = True+ allowReadOnly = True+ message = "Open " ++ toolName ++ " files"+ directory = "examples"+ filename = ""++-- | For each INblobs file add some info to the report.+reportPerFile :: (InfoKind n g, InfoKind e g, XmlContent g, Show g) =>+ State g n e -> TextCtrl () -> [Check g n e] -> FilePath -> IO ()+reportPerFile _ txt chks fname =+ do+ contents <- strictReadFile fname+ let errorOrDocument = DocumentFile.fromString contents+ textCtrlAppendText txt $ fname ++ "\n"+ case errorOrDocument of+ Left err -> addError2TextCtrl txt $ err ++ "\nChecks not performed.\n"+ Right (doc, [], False) ->+ case runChecksOver doc chks of+ (goodsStr, Nothing) -> addGood2TextCtrl txt "All checks passed"+ (goodsStr, Just (badsStr,badsStrLong)) ->+ do+ addGood2TextCtrl txt goodsStr+ addTxtOfColor2TextCtrl (wxcolor orange) txt badsStrLong++ Right (doc, warnings, True) ->+ addError2TextCtrl txt $+ "File read warning\n"+ ++ "The file you opened has the old " ++ toolName+ ++ " file format which will become obsolete in newer versions of "+ ++ toolName ++ ".\nChecks not performed.\n"++ Right (doc, warnings, False) ->+ addError2TextCtrl txt $+ "Warnings while reading file:\n\n"+ ++ unlines ( map ("* " ++) (take 10 warnings)+ ++ if length warnings > 10 then ["..."] else []+ )+ ++ "\n Most likely you are reading a file that is created by a newer version of "+ ++ toolName ++ ".\nChecks not performed.\n"+ textCtrlAppendText txt $ '\n': replicate 20 '#' ++ "\n\n"+
+ src/INReduction.hs view
@@ -0,0 +1,256 @@+module INReduction + (+ reduce+ , globalReduce+ , strategiesList+ ) where++import INReductionStrategies+import Network+import NetworkControl+import Document as Doc+import qualified Palette+import qualified PersistentDocument as PD+import State+import StateUtil+import SafetyNet+import INRules+import INRule+import Ports+import Shape+import Math+import Common+import InfoKind++import Data.Maybe+import Data.List++import Graphics.UI.WXCore+++-- | Tries to reduce the given edge in the network; one step reduction.+-- Its assumed that the edge is an active pair.+reduceStep :: (InfoKind n g, InfoKind e g) => EdgeNr -> State g n e -> IO ()+reduceStep edgeNr state = + do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ theFrame <- getNetworkFrame state+ let network = getNetwork doc+ edge = getEdge edgeNr network++ safetyNet theFrame $+ let (nodeNrFrom, portFrom) = getFullPortFrom edge+ (nodeNrTo , portTo ) = getFullPortTo edge+ nodeFrom = getNode nodeNrFrom network+ nodeTo = getNode nodeNrTo network++ in case findMatchingRules nodeFrom nodeTo portFrom portTo $ getRules doc of+ [] -> warningDialog theFrame "No matching rule" + "Reduction not performed because no rule matches this active pair." + [(rule, lhsN1Nr, lhsN2Nr, lhsEdgeNr)] + -> -- good case; exactly one rule applies+ do logMessage $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."+ putStrLn $ "Rule \"" ++ INRule.getName rule ++ "\" will be applied."++ PD.updateDocument "reduce" + (\doc -> (updateNetwork $+ reallyReduce (getPalette doc)+ nodeNrFrom portFrom nodeNrTo portTo edgeNr+ rule + lhsN1Nr lhsN2Nr lhsEdgeNr ) + . setSelection NoSelection $ doc)+ pDoc+ + setActiveRule (INRule.getName rule) state+ -- tree <- getTree state+ -- item <- get item by name+ -- treeCtrlSelect tree item + repaintAll state ++ _ -> warningDialog theFrame "Wrong system" + $ "Reduction not performed because more than one rule can be applied to"+ ++ " the selected active pair.\n\n"+ ++ "This set of rules isn't an Interaction system.\n"+ ++ "Correct the rules."+++reallyReduce :: (InfoKind n g, InfoKind e g) => Palette.Palette n ->+ NodeNr -> PortName -> NodeNr -> PortName -> EdgeNr -- ^ active pair details from the net to reduce+ -> INRule g n e -- ^ rule + -> NodeNr -> NodeNr -> EdgeNr -- ^ active pair details from the lhs of rule+ -> Network g n e -> Network g n e+reallyReduce palette nFromNr portFrom nToNr portTo edgeNr rule lhsnNr1 lhsnNr2 lhsEdgeNr network =+ let (inter, noInter) = partition isInterfaceNode . getNodeAssocs . getRHS $ rule+ (interNrs, noInterNrs) = map fst >< map fst $ (inter, noInter)++ (net1, nrs) = copy2network (map snd noInter) $ getNodePosition network nFromNr+ nodeMaps = zip noInterNrs nrs++ nFromPorts, nToPorts :: Ports+ nFromPorts = tail . cleanJust $ getPorts palette network nFromNr -- excludes the principal one+ nToPorts = tail . cleanJust $ getPorts palette network nToNr -- excludes the principal one++ nFromPorts', nToPorts' :: [(NodeNr, PortName)]+ nFromPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nFromNr . fst) nFromPorts+ nToPorts' = map (cleanJust . otherExtremeOfEdgeConnectedOnPort network nToNr . fst) nToPorts++ nFromInterLHS, nToInterLHS :: [(NodeNr, PortName)]+ nFromInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr1 . fst) nFromPorts+ nToInterLHS = map (cleanJust . otherExtremeOfEdgeConnectedOnPort (getLHS rule) lhsnNr2 . fst) nToPorts++ nFromInterRHS, nToInterRHS :: [(NodeNr, PortName)]+ nFromInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nFromInterLHS+ nToInterRHS = map ( ( moveThroughMapping (getMapping rule) ) >< id ) nToInterLHS++ nFromPortsRHS, nToPortsRHS :: [(NodeNr, PortName)]+ nFromPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nFromInterRHS+ nToPortsRHS = map (\(nNr, port) -> cleanJust . otherExtremeOfEdgeConnectedOnPort (getRHS rule) nNr $ port) nToInterRHS++ oneStepBeforeRelation :: [((NodeNr, PortName),(NodeNr, PortName))]+ oneStepBeforeRelation = zip nFromInterRHS nFromPorts' ++ zip nToInterRHS nToPorts'++ edgesInvolvingNodesToBeRemove e@((a,_),(b,_)) (ly,ln) | a `elem` [nToNr, nFromNr] = (e:ly , ln)+ | b `elem` [nToNr, nFromNr] = (swap e : ly, ln)+ | otherwise = (ly , e:ln) + correctEdge [(_,from), (_,to)] = (from, to)+ correctEdge _ = error "A list of two elements was expected but one of different length was found in reduction function."++ nodesToBeRemoveConnected :: ((NodeNr, PortName),(NodeNr, PortName)) -> ((NodeNr, PortName),(NodeNr, PortName)) -> Bool+ nodesToBeRemoveConnected ((nr1,p1),_) (c,_) = Just c == otherExtremeOfEdgeConnectedOnPort network nr1 p1++ listEdges' = + (\(a,b) -> a ++ b) . + ((map correctEdge . groupBy nodesToBeRemoveConnected . nub) >< id) .+ foldr edgesInvolvingNodesToBeRemove ([],[]) .+ map (id >< either id (updateNr nodeMaps >< id)) . + eliminateDummyConnections oneStepBeforeRelation . + map (id >< sepInterface) + $ zip nFromPorts' nFromPortsRHS ++ zip nToPorts' nToPortsRHS+++ net3 = removeNode nToNr . removeNode nFromNr .+ -- add edges from RHS that don't involve interface agents+ copyEdgesWithoutInterface nodeMaps net1 . edgesWithoutInterface interNrs . getRHS $ rule+ + in foldl ( \network ((nF,pF),(nT,pT)) -> addEdge palette nF pF nT pT network) net3 listEdges'+ where -- | copy agents others than interface from rhs to network updating node positions+ copy2network [] _ = (network, [])+ copy2network l@(rhsN1:xs) netPos = + let delta = subtractDoublePoint netPos $ getPosition rhsN1+ in mapAccumL (addNodeUpd delta) network l++ -- addNodeUpd :: DoublePoint -> Network g n e -> Node n -> (Network g n e, NodeNr)+ addNodeUpd delta net node = swap $ addExistingNode (updatePosition delta node) net++ updatePosition delta node = + setPosition (translate delta $ getPosition node) node++ isConnectedToInterface :: [EdgeNr] -> Edge e -> Bool+ isConnectedToInterface interNrs edge = + getEdgeFrom edge `elem` interNrs || getEdgeTo edge `elem` interNrs++ -- edges from network that are not connected to an interface agent+ edgesWithoutInterface :: [NodeNr] -> Network g n e -> [Edge e]+ edgesWithoutInterface interNrs = filter (not . isConnectedToInterface interNrs) . getEdges++ -- copyEdgesWithoutInterface :: [(NodeNr, NodeNr)] -> Network g n e -> [Edge e] + -- -> Network g n e+ copyEdgesWithoutInterface nodeMaps = foldl $ addEdgeUpdatingNodeNrs nodeMaps++ addEdgeUpdatingNodeNrs nodeMaps network edge = + addEdge palette (updateNr nodeMaps $ getEdgeFrom edge) (getPortFrom edge)+ (updateNr nodeMaps $ getEdgeTo edge) (getPortTo edge) network++ updateNr :: [(NodeNr, NodeNr)] -> NodeNr -> NodeNr+ updateNr nodeMaps nodeNr = maybe nodeNr id $ lookup nodeNr nodeMaps++ cleanJust = takeJust "A port was expected here."++ moveThroughMapping :: Mapping -> NodeNr -> NodeNr+ moveThroughMapping maps elem = takeJust "Mapping not found." $ lookup elem maps++ sepInterface :: (NodeNr, PortName) -> Either (NodeNr, PortName) (NodeNr, PortName)+ sepInterface x@(nodeNr, port) = if isInterfacePort port then Left x else Right x++ eliminateDummyConnections :: [((NodeNr, PortName),(NodeNr, PortName))]+ -> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]+ -> [(a, Either (NodeNr, PortName) (NodeNr, PortName))]+ eliminateDummyConnections oneStepBeforeRelation = + map (id >< either onLeftCase Right )+ where onLeftCase interA = Left . takeJust "unexpected error" $ lookup interA oneStepBeforeRelation+++globalReduce :: (InfoKind n g, InfoKind e g) => Strategy -> Bool -> State g n e -> IO ()+globalReduce strategy manySteps state =+ do pDoc <- getDocument state+ doc <- PD.getDocument pDoc+ theFrame <- getNetworkFrame state+ let network = getNetwork doc+ palette = getPalette doc+ logMessage $ "STRATEGY: " ++ strategy++ safetyNet theFrame $++ case filterActivePairs palette network of+ [] -> infoDialog theFrame "Nothing to be done" "The net has no active pairs, so there is nothing to reduce."+ l -> case choose l strategy doc of -- choose one active pair+ Result chosen | isActivePair chosen palette network ->+ do PD.superficialUpdateDocument (setSelection $ EdgeSelection Net chosen) pDoc+ repaintAll state + wxcAppYield+ reduceStep chosen state+ continue <- getContinueReduction state+ when (manySteps && continue) $ globalReduce strategy manySteps state+ Result _ -> errorDialog theFrame "Not an active pair" $ + "The given/choosen edge is not an active pair.\nThis is due to " + ++ case strategy of + "Manual selection" -> "wrong user choice.\nPlease choose one edge that is an active pair."+ _ -> "wrong strategy implementation.\nPlease report bug to authors."+ ErrorD str1 str2 -> errorDialog theFrame str1 str2+ InfoD str1 str2 -> infoDialog theFrame str1 str2+++ where filterActivePairs palette network = filter (\edgeNr -> isActivePair edgeNr palette network)+ . map fst $ getEdgeAssocs network++-- | Choose one active pair from the none empty list of active pairs+choose :: [EdgeNr] -- ^ none empty list of all active pairs in the network+ -> Strategy -- ^ strategy to use in choice process+ -> Doc.Document g n e -- ^ document+ -> PossibleResult EdgeNr -- ^ edgeNr to reduce or thrown error message+choose lAPs strategy doc =+ case lookup strategy strategiesList of+ Nothing -> ErrorD "Error" "Strategy name without choose function.\nPlease report bug to authors."+ Just func -> func lAPs doc+++findMatchingRules :: Node n -> Node m -> PortName -> PortName -> INRules g n e+ -> [(INRule g n e, NodeNr, NodeNr, EdgeNr)]+findMatchingRules nodeFrom nodeTo portFrom portTo rules = + catMaybes + . map ( findCorrespondence (getShape nodeFrom) (getShape nodeTo) portFrom portTo ) + $ rules++findCorrespondence :: Palette.ShapeName -> Palette.ShapeName -> PortName -> PortName+ -> INRule g n e + -> Maybe (INRule g n e, NodeNr, NodeNr, EdgeNr)+findCorrespondence shapeFrom shapeTo portFrom portTo rule =+ case filter (not . isInterfaceNode) . getNodeAssocs . getLHS $ rule of+ [(n1Nr,n1),(n2Nr,n2)] + | (getShape n1, getShape n2) == (shapeFrom, shapeTo) -> aux n1Nr n2Nr+ | (getShape n2, getShape n1) == (shapeFrom, shapeTo) -> aux n2Nr n1Nr+ | otherwise -> Nothing+ _ -> error $ "The LHS of rule \"" ++ INRule.getName rule ++ + "\" is wrong; exactly two agents other than interface were expected but not found."+ where aux nNr1 nNr2 = + case findEdge nNr1 portFrom nNr2 portTo (getLHS rule) of+ Nothing -> case findEdge nNr2 portTo nNr1 portFrom (getLHS rule) of+ Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)+ Nothing -> Nothing+ Just edgeNr -> Just (rule, nNr1, nNr2, edgeNr)+++-- | Reduce the selected edge in the network; one step reduction.+reduce :: (InfoKind n g, InfoKind e g) => State g n e -> IO () +reduce = globalReduce "Manual selection" False+
+ src/INReductionStrategies.hs view
@@ -0,0 +1,96 @@+-- | If someone wants to give a new reduction strategy have to:+--+-- 1. add a new entry in @strategiesList@ (e.g. @(\"New Strategy string\", choose_NewStrategy_function)@)+--+-- 2. define @choose_NewStrategy_function :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr@+module INReductionStrategies where++import Document+import Network+import INRule+import Palette++import Data.Maybe++data PossibleResult a = Result a | ErrorD String String | InfoD String String++-- | Checks if the given edge is an active pair.+isActivePair :: EdgeNr -> Palette n -> Network g n e -> Bool+isActivePair edgeNr palette network =+ isPrincipalPort palette network nodeNrFrom portFrom+ && isPrincipalPort palette network nodeNrTo portTo+ && not (isInterfaceNode (nodeNrFrom, getNode nodeNrFrom network) ) + && not (isInterfaceNode (nodeNrTo, getNode nodeNrTo network) )+ where edge = getEdge edgeNr network+ (nodeNrFrom, portFrom) = getFullPortFrom edge+ (nodeNrTo, portTo) = getFullPortTo edge++-- | Checks if an interface node is connected through an active pair. +isTheInterfaceActivePair :: EdgeNr -> Palette n -> Network g n e -> Bool+isTheInterfaceActivePair edgeNr palette network =+ isPrincipalPort palette network nodeNrFrom portFrom+ && isPrincipalPort palette network nodeNrTo portTo+ where edge = getEdge edgeNr network+ (nodeNrFrom, portFrom) = getFullPortFrom edge+ (nodeNrTo, portTo) = getFullPortTo edge++++type Strategy = String++-- | List of pairs (Strategy name, strategy choose function)+strategiesList :: [(Strategy -- strategy name+ , [EdgeNr] -- none empty list of all active pairs in the network+ -> Document g n e -- document+ -> PossibleResult EdgeNr -- edgeNr to reduce or thrown error message+ )]+strategiesList = + [ ("Manual selection", chooseManualSelection)+ , ("Random", chooseRandom)+ , ("WRINF", chooseWRINF)+ ] ++chooseManualSelection :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr+chooseManualSelection _ doc = case getSelection doc of+ EdgeSelection Net edgeNr -> Result edgeNr + _ -> ErrorD "Reduction error" "Please select an active pair first and press 'REDUCE' again."++chooseRandom :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr+chooseRandom lAPs _ = Result $ head lAPs+++-- | WRINF Strategy +chooseWRINF :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr+chooseWRINF _ doc = + case filter isInterfaceNode $ getNodeAssocs network of+ [(interface,_)] -> + if (isTheInterfaceActivePair (dd palette network interface) palette network)+ then InfoD "WRINF is done" "Nothing to be done using WRINF strategy"+ else case walk palette network [] interface of+ Nothing -> InfoD "WRINF is done" "Nothing to be done using WRINF strategy"+ Just e -> Result e+ where network = getNetwork doc+ palette = getPalette doc++walk :: Palette n -> Network g n e -> [NodeNr] -> NodeNr -> Maybe EdgeNr+walk palette network visited node_start | (node_start `elem` visited) = Nothing+ | otherwise = let pp = filter (isPrincipalPort palette network node_start . fst)+ . fromMaybe [] $ getPorts palette network node_start+ in case pp of + [] -> Nothing+ [(x,_)] -> let edgeOnPPort = edgeConnectedOnPort network node_start x;+ in case edgeOnPPort of+ (Just e) -> if (isActivePair e palette network )+ then (Just e) + else let next_node = fst . fromJust $ otherExtremeOfEdgeConnectedOnPort network node_start x + in walk palette network (node_start:visited) next_node;+ _ -> Nothing;++dd :: Palette n -> Network g n e -> NodeNr -> EdgeNr+dd palette nt nr = let por = map fst . fromMaybe [] $ getPorts palette nt nr+ in head . catMaybes $ map (edgeConnectedOnPort nt nr ) por +-- END of WRINF+++-- chooseNewStrategy :: [EdgeNr] -> Document g n e -> PossibleResult EdgeNr+
+ src/INRule.hs view
@@ -0,0 +1,144 @@+{-| Module : INRule+ Maitainer : jmvilaca@di.uminho.pt++ +-}++module INRule + ( INRule+ , Mapping+ , MappingElement + , initial++ , getName, setName+ , getLHS, setLHS+ , getRHS, setRHS+ , getMapping, setMapping+ , construct+ + , updateLHS+ , updateRHS+ , updateMapping+ , copyLHS2RHS+ , copyLHSInterface2RHS+ + , addMapping+ , showsMapping+ , isInterfaceNode+ ) where++import Network hiding (getName, setName) +import Ports+import InfoKind+import Common+import qualified Data.IntMap as IntMap (empty)+import SpecialSymbols++import Data.List+++data INRule g n e = INRule + { ruleName :: String -- ^ the name of the rule+ , ruleLHS :: Network g n e -- ^ the rule LHS network + , ruleRHS :: Network g n e -- ^ the rule RHS network + , ruleMaps :: Mapping -- ^ mappings between the LHS and RHS+ } deriving (Show)++-- | @(n_i, n_j)@ means that node n_i in the LHS of the rule corresponds to node n_j in the RHS+-- @n_i@ and @n_j@ have to be interface nodes+type MappingElement = (NodeNr, NodeNr)+type Mapping = [MappingElement] ++showsMapping :: Mapping -> ShowS+showsMapping [] = showString "{}"+showsMapping (x:xs) =+ showChar '{' . showsE x . showl xs+ where showl [] = showChar '}'+ showl (x:xs) = showChar ',' . showsE x . showl xs+ showsE (from,to) = shows from . showString " |-> " . shows to++initial :: (InfoKind e g, InfoKind n g) => g -> n -> e -> INRule g n e+initial g n e =+ INRule { ruleName = "Rule 1"+ , ruleLHS = Network.empty g n e + , ruleRHS = Network.empty g n e+ , ruleMaps = []+ }++-- Set's e Get's+getName :: INRule g n e -> String+getName = ruleName++getLHS :: INRule g n e -> Network g n e+getLHS = ruleLHS ++getRHS :: INRule g n e -> Network g n e+getRHS = ruleRHS++getMapping :: INRule g n e -> Mapping+getMapping = ruleMaps++setName :: String -> INRule g n e -> INRule g n e+setName newRuleName rule = rule { ruleName = newRuleName}++setLHS :: Network g n e -> INRule g n e -> INRule g n e+setLHS newRuleLHS rule = rule { ruleLHS = newRuleLHS}++setRHS :: Network g n e -> INRule g n e -> INRule g n e+setRHS newRuleRHS rule = rule { ruleRHS = newRuleRHS}++setMapping :: Mapping -> INRule g n e -> INRule g n e+setMapping newRuleMaps rule = rule { ruleMaps = newRuleMaps}++construct :: String -- ^ rule name+ -> Network g n e -- ^ lhs+ -> Network g n e -- ^ rhs+ -> Mapping -- ^ correspondences between + -- lhs and rhs interface+ -> INRule g n e+construct theRuleName lhs rhs mapping =+ INRule { ruleName = theRuleName+ , ruleLHS = lhs + , ruleRHS = rhs+ , ruleMaps = mapping+ }++-- update LHS and RHS networks and mapping++updateLHS :: (Network g n e -> Network g n e)+ -> INRule g n e -> INRule g n e+updateLHS networkFun rule = rule { ruleLHS = networkFun $ ruleLHS rule }++updateRHS :: (Network g n e -> Network g n e)+ -> INRule g n e -> INRule g n e+updateRHS networkFun rule = rule { ruleRHS = networkFun $ ruleRHS rule }++updateMapping :: (Mapping -> Mapping)+ -> INRule g n e -> INRule g n e+updateMapping mapFun rule = rule { ruleMaps = mapFun $ ruleMaps rule }++copyLHS2RHS :: INRule g n e -> INRule g n e+copyLHS2RHS rule = + rule { ruleRHS = lhs+ , ruleMaps = map (diag . fst) . filter isInterfaceNode $ getNodeAssocs lhs+ }+ where lhs = ruleLHS rule++copyLHSInterface2RHS :: INRule g n e -> INRule g n e+copyLHSInterface2RHS rule = + rule { ruleRHS = setNodeAssocs lhs' . emptyNodesAndEdges $ ruleRHS rule + , ruleMaps = map (diag . fst) $ lhs'+ }+ where lhs' = filter isInterfaceNode . getNodeAssocs $ ruleLHS rule+ emptyNodesAndEdges net = net { networkNodes = IntMap.empty+ , networkEdges = IntMap.empty }+ +-- operations on Mappings+addMapping :: MappingElement -> Mapping -> Mapping+addMapping = insert ++-- auxiliar functions+isInterfaceNode :: (NodeNr, Node n) -> Bool+isInterfaceNode (_, node) = getShape node == interName+ where (interName, interDef) = interfaceSymbol+
+ src/INRules.hs view
@@ -0,0 +1,69 @@+{-| Module : INRules+ Maitainer : jmvilaca@di.uminho.pt++ +-}++module INRules+ ( INRules+ , empty++ , updateRule+ , rulesNames+ , findRule+ , fromRule+ , addNewRule+ , addNewEmptyRule+ , removeRule++ , mapRules+ ) where++import INRule+import InfoKind++import Data.List++type INRules g n e = [INRule g n e] ++-- | Empty set of rules.+empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> INRules g n e+empty g n e = []+++updateRule :: String -> (INRule g n e -> INRule g n e) + -> INRules g n e -> INRules g n e+updateRule ruleName ruleFunc rules = map f rules + where f rule | ruleName == getName rule = ruleFunc rule+ | otherwise = rule++rulesNames :: INRules g n e -> [String]+rulesNames = map getName ++sameName :: String -> INRule g n e -> Bool+sameName ruleName rule = (getName rule) == ruleName++findRule :: String -> INRules g n e -> Maybe (INRule g n e)+findRule ruleName rules = find (sameName ruleName) rules++fromRule :: (INRule g n e -> x) -> String -> INRules g n e -> Maybe x+fromRule func ruleName rules = + case findRule ruleName rules of+ Just rule -> Just $ func rule+ Nothing -> Nothing ++addNewRule :: INRule g n e -> INRules g n e -> INRules g n e+addNewRule newRule rules = rules ++ [newRule]++addNewEmptyRule :: (InfoKind e g, InfoKind n g) => + String -> g -> n -> e -> INRules g n e -> INRules g n e +addNewEmptyRule ruleName g n e rules = + let newRule = setName ruleName $ initial g n e+ in addNewRule newRule rules ++removeRule :: (InfoKind e g, InfoKind n g) => + String -> INRules g n e -> INRules g n e+removeRule ruleName rules = filter (not . sameName ruleName) rules++mapRules :: (INRule g n e -> x) -> INRules g n e -> [x]+mapRules = map
+ src/INTextual.hs view
@@ -0,0 +1,315 @@+module INTextual + (+ Net (..)+ , doc2net+ , network2net+ , textualRule+ , toRuleNet -- tricky function with unsafe operations inside+ , simplify+ , filterRules+ , filterNet++ , Representation (..)+ , showRepresentation+ )where++import Document hiding (ActiveCanvas(..))+import Network+import qualified Palette as Pal+import Constants+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Char+import Data.List+import Common+import INRules+import INRule+import InfoKind+import SpecialSymbols+++type Edge' = EdgeNr+type AgentName = String+type Agent = (AgentName -- agent name+ , Int -- the agent arity, this is, the number of ports+ -- excludind the principal one+ )+type Interface = [Term]++-- | (rules, <interface | equations>) is a configuration+data Net = Net { agents :: [Agent] -- ^ the list of agents and its arities+ , equations :: [Equation] -- ^ the equations+ , interface :: Interface -- ^ the interface of the net+ -- + , rules :: [Rule] -- ^ rules+ } deriving (Eq)++type NodeApl = (AgentName, [Term])+data Term = Simple Edge' | Compound NodeApl deriving (Eq, Ord, Show)+type Equation = (Term, Term)++type Rule = (Maybe String, NodeApl, NodeApl)+++instance Show Net where+ show = showRepresentation PIN++{-+generalRepresentation :: Net -> String+generalRepresentation = unlines . map showEquation . equations+ where showEquation (edge, info) = (showEdge edge) ++ " = " ++ showNodeApl info ++ " ;"+ showNodeApl (node, edges) = + showNode node ++ if null edges+ then ""+ else "(" ++ showTerm (head edges) + ++ showTail (tail edges)+ ++ ")"+ showEdge = int2name + showNode node = filter (not . isSpace) node+ showTail = concatMap (\a -> ", " ++ showTerm a)+-}++data Representation = AMIN | PIN deriving Show++repFold amin pin rep = case rep of + AMIN -> amin+ PIN -> pin ++-- | Creates the string with the representation of a 'Net' +-- in the format of IN transformation tools:+-- * AMIN+-- * PIN+showRepresentation :: Representation -> Net -> String+showRepresentation rep net =+ unlines ( + [ "/* Automatically generated by " ++ toolName ++ " for " ++ show rep ++ " */"+ , ""+ , repFold "agents" "" rep+ , "" + ] ++ map showAgent (agents net) ++ + [ ""+ , repFold "rules" "" rep+ , ""+ ] ++ map showRule (rules net) ++ + [ ""+ , repFold "net" "//test net\nstart :" rep+ , ""+ ] ++ map showEquation (equations net) +++ case rep of + AMIN -> [ ""+ , "interface"+ , ""+ ] ++ map showEdge2 (interface net) ++ + [ ""+ , ""+ , "end"+ ]+ PIN -> []+ )+ where showAgent :: Agent -> String+ showAgent (name, arity) = sl (spaces2underscores name) (repFold "\t" ":" rep) $ show arity++ showEquation :: Equation -> String+ showEquation (lhs, rhs) = sl (showTerm lhs) (repFold " = " " - " rep) $ showTerm rhs+ + showTerm (Simple e) = showEdge e+ showTerm (Compound c) = showNodeApl c++ showNodeApl (node, edges) = + showNode node ++ if null edges+ then ""+ else "(" ++ showTerm (head edges) + ++ showTail (tail edges)+ ++ ")" + showNode node = spaces2underscores node+ showTail = concatMap (\a -> ", " ++ showTerm a)++ showEdge :: Edge' -> String+ showEdge = int2name+ + showEdge2 term = showTerm term ++ ";"++ sl arg1 sep arg2 = '\t' : arg1 ++ sep ++ arg2 ++ repFold ";" [] rep++ showRule (mStr, lhs, rhs) = repFold [] (maybe [] ((++ ":\n") . spaces2underscores) mStr) rep+ ++ sl (showNodeApl lhs) " >< " (showNodeApl rhs) ++ "\n"+ ++doc2net :: (InfoKind n g, InfoKind e g) => Document g n e -> Net+doc2net doc = nubAgents $ (network2net palette $ getNetwork doc)+ `join` + (foldr1 join . mapRules (textualRule palette) $ getRules doc)+ where palette = getPalette doc++nubAgents :: Net -> Net+nubAgents net = net { agents = nub $ agents net}+ +join :: Net -> Net -> Net+join net1 net2 =+ Net { agents = agents net1 ++ agents net2+ , equations = equations net1 ++ equations net2+ , interface = interface net1 ++ interface net2+ , rules = rules net1 ++ rules net2+ } ++network2net :: Pal.Palette n -> Network g n e -> Net+network2net palette network =+ Net { agents = delete (fst interfaceSymbol, 0) . nub+ . map getAgent . IM.assocs $ nodeMap+ , equations = sort eqs'+ , interface = map fst inter+ , rules = []+ } + where nodeMap = networkNodes network+ + eqs = catMaybes $ IM.foldWithKey f [] nodeMap+ (eqs', inter) = partition test eqs+ f nodeNr node r = (node2net nodeNr node) : r+ node2net :: NodeNr -> Node n -> Maybe Equation+ node2net nr node = + do (pPort:otherPorts) <- getPorts palette network nr+ pEdge <- edgeConnectedOnPort network nr (fst pPort)+ let otherEdges = catMaybes $ map (edgeConnectedOnPort network nr . fst) otherPorts+ return (Simple pEdge, Compound (getShape node, map Simple otherEdges))+ test :: Equation -> Bool+ test (Simple _, Compound (str, [])) = str /= fst interfaceSymbol+ test _ = True+ getAgent :: (NodeNr, Node n) -> (AgentName, Int)+ getAgent (nr,node) = (getShape node, agentArity nr)+ agentArity :: NodeNr -> Int+ agentArity nr = length (maybe [] id $ getPorts palette network nr) - 1++-- | Generates the textual representation of a rule.+textualRule :: (InfoKind n g, InfoKind e g) => Pal.Palette n -> INRule g n e -> Net+textualRule palette rule =+ let lhs = getLHS rule+ rhs = getRHS rule+ ruleName = INRule.getName rule + (interface, others) = partition isInterfaceNode $ getNodeAssocs lhs++ f :: (NodeNr -> NodeNr) -> Network g n e -> MappingElement -> Network g n e+ f new oldnet (nil, nir) =+ let redge = takeJust ("One interface agent in rhs of rule " + ++ ruleName ++ " is disconnected.")+ $ edgeConnectedOnPort oldnet nir "interface"+ (nl, pl) = takeJust ("One interface agent in lhs of rule " + ++ ruleName ++ " is disconnected.")+ $ otherExtremeOfEdgeConnectedOnPort lhs nil "interface"++ in removeNode nir . updateEdge redge (substBy (nir, "interface") (new nl, pl)) $ oldnet+ f _ _ _ = error "unknow error"++ substBy (oldNode, oldPort) (newNode, newPort) edge = + case getFullPortFrom edge of+ (node, port) | node == oldNode && port == oldPort+ -> setPortFrom newNode newPort edge+ _ -> case getFullPortTo edge of+ (node, port) | node == oldNode && port == oldPort+ -> setPortTo newNode newPort edge+ _ -> error "unexpected"+ + in case others of + [(n1, a), (n2, b)] | hasActivePair n1 n2 lhs palette ->+ let aPrincipalPort = head . fromJust $ getPorts palette lhs n1+ bPrincipalPort = head . fromJust $ getPorts palette lhs n2+ (na, rhs1) = addExistingNode a rhs + (nb, rhs2) = addExistingNode b rhs1+ rhs3 = addEdge palette na (fst aPrincipalPort) nb (fst bPrincipalPort) rhs2++ new n | n==n1 = na+ | n==n2 = nb+ | otherwise = error "unknow error"++ -- connect mapping with wires removing interface agents+ rhs4 = foldl (f new) rhs3 $ getMapping rule++ in toRuleNet ruleName . simplify . network2net palette $ rhs4+ + _ -> if isEmpty lhs + then error $ "LHS of rule " ++ ruleName ++ " is empty."+ else error $ "LHS of rule " ++ ruleName ++ " must have just one active pair and interface and it was found something differente. Maybe it was a "+ + ++hasActivePair :: NodeNr-> NodeNr -> Network g n e -> Pal.Palette n -> Bool+hasActivePair n1 n2 net palette =+ case (getPorts palette net n1, getPorts palette net n2) of+ (Just ((ap,_):_), Just ((bp,_):_) ) ->+ isJust ( findEdge n1 ap n2 bp net ) ||+ isJust ( findEdge n2 bp n1 ap net )+ _ -> False++toRuleNet :: String -> Net -> Net+toRuleNet ruleName net = + if null $ interface net+ then case equations net of+ [(Compound x, Compound y)] -> net {equations = [], rules = [(Just ruleName,x,y)]}+ x:xs | not $ null xs -> error $ "Rule " ++ ruleName ++ " probably has active pair(s) in its rhs."+ y -> error $ "Internal error in textual representation generation of rule " + ++ ruleName ++ " or unknow error." ++ show y+ + else error $ "Rule " ++ ruleName ++ " with interface: internal error in textual representation generation or mismatching interfaces between lhs and rhs."++simplify :: Net -> Net+simplify net = Net { agents = agents net+ , equations = eqs''+ , interface = inter'+ , rules = rules net }+ where inter = interface net+ eqs' = simp [] (equations net)+ (eqs'', inter') = simp2 inter eqs'++ -- | @ simp @ removes equations of form @ a = X @ + -- for something as @ X @ and for any @ a @ + -- that don't belong to the interface,+ -- substituting the unique occurence of @ a @ + -- in the others equations.+ simp :: [Equation] -- ^ the equations already folded+ -> [Equation] -- ^ the equations to fold + -> [Equation] -- ^ the result+ simp eqsB [] = eqsB+ simp eqsB (eq@(Compound _, _) : eqsA) = simp (eqsB ++ [eq]) eqsA+ simp eqsB (eq@(Simple x , a) : eqsA) + | Simple x `elem` inter = simp (eqsB ++ [eq]) eqsA+ | otherwise = simp eqsBS eqsAS+ where (eqsBS, eqsAS) = subst2 (Simple x) a eqsB eqsA++ -- | @ simp2 @ removes the equations of form @ a = X @ + -- for something as @ X @ and for any @ a @ + -- that belong to the interface, + -- substituting @ a @ by @ X @ in the interface.+ simp2 :: Interface -> [Equation] -> ([Equation], Interface)+ simp2 i = foldl f2 ([],i)+ f2 :: ([Equation], Interface) -> Equation -> ([Equation], Interface)+ f2 (eqsB, i) (Simple x , a)+ | Simple x `elem` i = (eqsB, a : delete (Simple x) i)+ | otherwise = error "unexpected case in the simplification of a net: free edge don't belong to the interface"+ f2 (eqsB, i) eq = (eqsB ++ [eq], i)++ -- | It's known that exactly one occurency of the edge will be found + -- in the equations (eqsB ++ eqsA).+ -- In the future the function will be optimize for this invariant.+ -- Now it simply transverse the whole tree and replaces in the correct place.+ subst2 :: Term -> Term -> [Equation] -> [Equation] + -> ([Equation], [Equation])+ subst2 (Compound _) _ _ _ = error "unexpected case"+ subst2 (Simple x) rhs eqsB eqsA = (subst eqsB, subst eqsA)+ where subst :: [Equation] -> [Equation]+ subst = map (substTerm >< substTerm)+ + -- | Substitution in terms; t[rhs\/x] + -- with t the first argument of substTerm+ -- the occurence of variable @ x @ in term @ t @ + -- is replaced by term @ rhs @.+ substTerm (Simple a) | a == x = rhs+ | otherwise = Simple a+ substTerm (Compound c) = Compound . substNA $ c+ + substNA (agent, args) = (agent, map substTerm args)+++filterRules :: Net -> Net+filterRules net = net { equations = [], interface = [] }++filterNet :: Net -> Net+filterNet net = net { rules = []}
+ src/INTextualUI.hs view
@@ -0,0 +1,143 @@+module INTextualUI + ( genTextual+ , changeExt+ ) where++import Operations+import SafetyNet+import INTextual+import InfoKind+import State+import qualified PersistentDocument as PD++import Graphics.UI.WXCore hiding (Document)+import Graphics.UI.WX++import Data.Maybe++data What = Everything | JustRules | JustNet ++-- Generate textual description+genTextual :: (InfoKind n g, InfoKind e g) => IOOp g n e+genTextual doc state = + do mRes <- genTextualDialog state+ pDoc <- getDocument state+ inName <- PD.getFileName pDoc+ case mRes of + Nothing -> return ()+ Just (what, simp, wher, tool) -> + do let simpF = if simp then simplify else id+ filt = case what of+ Everything -> id+ JustRules -> filterRules+ JustNet -> filterNet+ net = filt . simpF $ doc2net doc++ if wher + then -- save to file+ do w <- getNetworkFrame state+ safetyNet w $+ do + let filename = changeExt ".INblobs" ('-':show tool ++ ".net") $ fromMaybe "" inName+ mf <- fileSaveDialog w + rememberCurrentDir overwritePrompt + "Save net equations"+ [("Net Files", ["*.net"])] + directory filename+ case mf of+ Nothing -> return ()+ Just fn -> writeFile fn . showRepresentation tool $ net+ + else -- print to screen+ do logMessage "printing Net"+ logMessage (showRepresentation tool net)+ putStr $ showRepresentation tool net+ where rememberCurrentDir = True+ overwritePrompt = True+ directory = "" ++-- | Change file extension and suffix filename.+changeExt :: String -- ^ \".INblobs\"+ -> String -- ^ \"-TOOL.net\"+ -> String -- ^ file.INblobs+ -> String -- ^ file-TOOL.net+changeExt old suffix = aux . span (/= '.')+ where+ aux (str,"") = str ++ suffix+ aux (str1, str2)+ | str2 == old = str1 ++ suffix+ | otherwise = let (str3,str4) = span (/='.') (tail str2)+ in aux (str1 ++ '.':str3, str4)++genTextualDialog :: State g n e -> IO (Maybe (What, Bool, Bool, Representation))+genTextualDialog state = + do theFrame <- getNetworkFrame state+ + dialog <- dialog theFrame + [ text := "Generate Textual Description"+-- , visible := True+ ]+ p <- panel dialog []++ let infoWhat = [ ("interaction system and net", Everything)+ , ("interaction system only", JustRules)+ , ("interaction net only",JustNet)+ ]+ (labelsWhat,dataWhat) = unzip infoWhat++ rWhat <- radioBox p Vertical labelsWhat + [ text := "Of :"+ , selection := 0 ]++ let infoSimp = [ ("simplified", True)+ , ("not simplified", False)+ ]+ (labelsSimp,dataSimp) = unzip infoSimp++ rSimp <- radioBox p Vertical labelsSimp + [ text := "Version :"+ , selection := 0 ]++ let infoWhere = [ ("save to file", True)+ , ("print to screen", False)+ ]+ (labelsWhere,dataWhere) = unzip infoWhere++ rWhere <- radioBox p Vertical labelsWhere + [ text := "To :"+ , selection := 0 ]+ let infoTool = [ ("AMIN", AMIN)+ , ("PIN", PIN)+ ]+ (labelsTool,dataTool) = unzip infoTool++ rTool <- radioBox p Vertical labelsTool + [ text := "Output Tool :"+ , selection := 0 ]++ ok <- button p [ text := "Ok" ]++ set dialog [ layout := container p $+ margin 10 $ + column 5 [ label "Generate textual description"+ , widget rWhat+ , widget rSimp + , widget rWhere+ , widget rTool+ , hfloatCentre $ widget ok + ]+ ]++ showModal dialog $ \stop ->+ do set ok [on command := + do iWhat <- get rWhat selection+ iSimp <- get rSimp selection+ iWhere <- get rWhere selection+ iTool <- get rTool selection++ stop (Just ( dataWhat !! iWhat+ , dataSimp !! iSimp+ , dataWhere !! iWhere+ , dataTool !! iTool+ )+ ) ]
+ src/InfoKind.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -fallow-undecidable-instances #-}+module InfoKind where++import Text.Parse+import Text.XML.HaXml.XmlContent++-- | The @InfoKind@ class is a predicate that ensures we can always create+-- at least a blank (empty) information element, that we can read and+-- write them to/from the user, and that there exists some method of+-- determining the correctness of the value (completeness/consistency etc)+-- against some global type.+class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where+ blank :: a+ check :: String -> g -> a -> [String] -- returns warnings+ -- ^ first arg is container label for error reporting.+ -- second arg is global value++-- A basic instance representing "no info"+instance InfoKind () () where+ blank = ()+ check _ _ () = []+-- Assume that info is mandatory, but not supplied a priori.+instance InfoKind a b => InfoKind (Maybe a) b where+ blank = Nothing+ check n _ Nothing = ["No info value stored with "++n]+ check n g (Just a) = check n g a+
+ src/Math.hs view
@@ -0,0 +1,114 @@+module Math+ ( DoublePoint(..), Vector+ , doublePointX, doublePointY+ , intPointToDoublePoint+ , doublePointToIntPoint+ , translatePolar+ , distancePointPoint+ , distanceSegmentPoint+ , subtractDoublePoint+ , subtractDoublePointVector+ , vectorLength+ , vectorAngle+ , origin+ , translate+ , enclosedInRectangle+ , scale+ ) where++import Graphics.UI.WX(Point, point, pointX, pointY)+import Text.Parse++{-+data DoublePoint = DoublePoint+ { doublePointX :: !Double+ , doublePointY :: !Double+ }+ deriving (Show, Eq, Read)+-}+data DoublePoint = DoublePoint !Double !Double+ deriving (Show, Eq, Read, Ord)++instance Parse DoublePoint where+ parse = do { isWord "DoublePoint"+ ; return DoublePoint `apply` parse `apply` parse+ }++data Vector = Vector !Double !Double++doublePointX (DoublePoint x _) = x+doublePointY (DoublePoint _ y) = y++origin :: DoublePoint+origin = DoublePoint 0 0++-- | Compute distance between two points+distancePointPoint :: DoublePoint -> DoublePoint -> Double+distancePointPoint (DoublePoint x0 y0) (DoublePoint x1 y1) =+ sqrt (square (x0 - x1) + square (y0 - y1))++square :: Double -> Double+square d = d*d++-- | Compute distance from a segment (as opposed to a line) to a point+-- Formulas taken from+-- <http://geometryalgorithms.com/Archive/algorithm_0102/algorithm_0102.htm>+distanceSegmentPoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double+distanceSegmentPoint p0 p1 p =+ let v = p1 `subtractDoublePointVector` p0+ w = p `subtractDoublePointVector` p0+ c1 = dotProduct w v+ c2 = dotProduct v v+ in if c1 <= 0 then distancePointPoint p p0+ else if c2 <= c1 then distancePointPoint p p1+ else distanceLinePoint p0 p1 p++-- | Compute distance from a line to a point+distanceLinePoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double+distanceLinePoint (DoublePoint x0 y0) (DoublePoint x1 y1) (DoublePoint x y) =+ abs ( ( (y0 - y1) * x + (x1 - x0) * y + (x0 * y1 - x1 * y0) ) /+ sqrt (square (x1 - x0) + square (y1 - y0))+ )++subtractDoublePointVector :: DoublePoint -> DoublePoint -> Vector+subtractDoublePointVector (DoublePoint x0 y0) (DoublePoint x1 y1) =+ Vector (x0 - x1) (y0 - y1)++-- | Translate a point relative to a new origin+translate :: DoublePoint -> DoublePoint -> DoublePoint+translate (DoublePoint originX originY) (DoublePoint x y) =+ DoublePoint (x+originX) (y+originY)++subtractDoublePoint :: DoublePoint -> DoublePoint -> DoublePoint+subtractDoublePoint (DoublePoint x0 y0) (DoublePoint x1 y1) =+ DoublePoint (x0 - x1) (y0 - y1)++dotProduct :: Vector -> Vector -> Double+dotProduct (Vector v1 v2) (Vector w1 w2) = v1 * w1 + v2 * w2++translatePolar :: Double -> Double -> DoublePoint -> DoublePoint+translatePolar angle distance (DoublePoint x y) =+ DoublePoint (x + cos angle * distance) (y + sin angle * distance)++doublePointToIntPoint :: DoublePoint -> Point+doublePointToIntPoint (DoublePoint x y) = point (round x) (round y)++intPointToDoublePoint :: Point -> DoublePoint+intPointToDoublePoint pt =+ DoublePoint (fromIntegral (pointX pt)) (fromIntegral (pointY pt))++vectorAngle :: Vector -> Double+vectorAngle (Vector v1 v2) = atan2 v2 v1++vectorLength :: Vector -> Double+vectorLength (Vector v1 v2) = sqrt (square v1 + square v2)++enclosedInRectangle :: DoublePoint -> DoublePoint -> DoublePoint -> Bool+enclosedInRectangle (DoublePoint x y) (DoublePoint x0 y0) (DoublePoint x1 y1) =+ between x x0 x1 && between y y0 y1+ where+ between i j k | j <= k = j <= i && i <= k+ | otherwise = k <= i && i <= j++scale :: Double -> DoublePoint -> DoublePoint+scale f (DoublePoint x y) = DoublePoint (f * x) (f * y)
+ src/Network.hs view
@@ -0,0 +1,662 @@+module Network+ (+ -- * Types+ Network, Node, Edge+ , NodeNr, EdgeNr, ViaNr+ , networkNodes -- dangerous+ , networkEdges -- dangerous++ -- * Creating and printing a network+ , Network.empty+ , Network.isEmpty+ , dumpNetwork+ -- ** Set\'s e get\'s+ , getNodeNrs+ , getNodeAssocs, setNodeAssocs+ , getEdgeAssocs, setEdgeAssocs+ , getCanvasSize, setCanvasSize+ , getGlobalInfo, setGlobalInfo+ -- ** Get usefull information from 'Network'+ , getNode+ , getEdge+ , getNodes+ , getEdges+ , getChildren+ , getParents+ , getParentMap, ParentMap+ -- ** Search\'s+ , nodeExists, edgeExists+ , findEdge, findNodeNrsByName+ , edgeConnectedOnPort+ , otherExtremeOfEdgeConnectedOnPort+ -- ** update network elements+ , updateNode+ , updateEdge+ , updateVia++ , mapNodeNetwork+ -- ** add and remove network elements+ , addNode, addNodes, removeNode, addNodeEx, addExistingNode+ , addEdge, addEdges, removeEdge+ , removeAllEdges+ , newViaEdge, removeVia++ -- * Node+ , constructNode+ -- ** get and set node data in a network by 'NodeNr' + , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape+ , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape+ -- ** get\'s and set\'s of a node+ , getInfo, getName, getPosition, getNameAbove, getShape+ , setInfo, setName, setPosition, setNameAbove, setShape+ -- * Edge+ , constructEdge+ , getEdgeFrom, getPortFrom, getEdgeTo, getPortTo, getEdgeVia, getEdgeInfo, getFullPortFrom, getFullPortTo+ , setEdgeFrom, setPortFrom, setEdgeTo, setPortTo, setEdgeVia, setEdgeInfo+ -- * Interaction Nets functionality+ , getPorts+ , getPort+ , isPrincipalPort+ , showEdge+ ) where++import Common+import Math+import InfoKind+import Shape+import Ports+import Palette (Palette, shapes, ShapeName, getSymbol)++import Data.IntMap as IntMap hiding (map)+import qualified Data.List as List+++data Network g n e = Network+ { networkNodes :: !(IntMap (Node n)) -- ^ maps node numbers to nodes+ , networkEdges :: !(IntMap (Edge e)) -- ^ maps edge numbers to edges+ , networkCanvasSize :: (Double, Double)+ , networkInfo :: g+ } deriving Show++data Edge e = Edge+ { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts+ , portFrom :: PortName --+ , edgeTo :: !NodeNr -- ^ the number of the node the edge points to+ , portTo :: PortName --+ , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing+ , edgeInfo :: e+ } deriving (Show, Read, Eq)++showEdge :: Edge e -> String+showEdge edge =+ "Node " ++ show (edgeFrom edge) ++ showPort (portFrom edge)+ ++ " |-> " +++ "Node " ++ show (edgeTo edge) ++ showPort (portTo edge)+ where+ showPort name = '@' : name++data Node n = Node+ { nodePosition :: DoublePoint -- ^ the position of the node on screen+ , nodeName :: !String+ , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False)+ , nodeShape :: ShapeName -- ^ symbol name from palette,+ , nodeInfo :: n+ } deriving (Show, Read)++type NodeNr = Int+type EdgeNr = Int+type ViaNr = Int++-- | Create an empty network+empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e+empty g _ _ = Network+ { networkNodes = IntMap.empty+ , networkEdges = IntMap.empty+ , networkCanvasSize = (15, 9)+ , networkInfo = g+ }++-- | Map a function over the nodes, possibly changes the type+-- of the Network (i.e. the kind of values stored in the+-- probability tables)+mapNodeNetwork :: InfoKind m g =>+ (Node n->Node m) -> Network g n e -> Network g m e+mapNodeNetwork nodeFun network =+ let numberedNodes = getNodeAssocs network+ newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ]+ in Network+ { networkNodes = IntMap.fromList newNodes+ , networkEdges = networkEdges network+ , networkCanvasSize = networkCanvasSize network+ , networkInfo = networkInfo network+ }++constructEdge :: NodeNr -> PortName -> NodeNr -> PortName -> [DoublePoint] -> e -> Edge e+constructEdge fromNr fromPort toNr toPort via info =+ Edge+ { edgeFrom = fromNr+ , portFrom = fromPort+ , edgeTo = toNr+ , portTo = toPort+ , edgeVia = via+ , edgeInfo = info+ }++getEdgeFrom :: Edge e -> NodeNr+getEdgeFrom = edgeFrom++getPortFrom :: Edge e -> PortName+getPortFrom = portFrom++getFullPortFrom :: Edge e -> (NodeNr, PortName)+getFullPortFrom e = (edgeFrom e, portFrom e)++getEdgeTo :: Edge e -> NodeNr+getEdgeTo = edgeTo++getPortTo :: Edge e -> PortName+getPortTo = portTo++getFullPortTo :: Edge e -> (NodeNr, PortName)+getFullPortTo e = (edgeTo e, portTo e)++getEdgeVia :: Edge e -> [DoublePoint]+getEdgeVia = edgeVia++getEdgeInfo :: Edge e -> e+getEdgeInfo = edgeInfo++setEdgeFrom :: NodeNr -> Edge e -> Edge e+setEdgeFrom fromNr edge = edge { edgeFrom = fromNr }++setPortFrom :: NodeNr -> PortName -> Edge e -> Edge e+setPortFrom fromNr fromPort edge = edge { edgeFrom = fromNr, portFrom = fromPort }++setEdgeTo :: NodeNr -> Edge e -> Edge e+setEdgeTo toNr edge = edge { edgeTo = toNr }++setPortTo :: NodeNr -> PortName -> Edge e -> Edge e+setPortTo toNr toPort edge = edge { edgeTo = toNr, portTo = toPort }++setEdgeVia :: [DoublePoint] -> Edge e -> Edge e+setEdgeVia via edge = edge { edgeVia = via }++setEdgeInfo :: e -> Edge oldInfo -> Edge e+setEdgeInfo info edge =+ constructEdge (getEdgeFrom edge) (portFrom edge)+ (getEdgeTo edge) (portTo edge)+ (getEdgeVia edge) info++constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool+ -> ShapeName -> n -> Node n+constructNode name position nameAbove shape info =+ Node+ { nodeName = name+ , nodePosition = position+ , nodeNameAbove = nameAbove+ , nodeShape = shape+ , nodeInfo = info+ }++getNodeName :: Network g n e -> NodeNr -> String+getNodeName network nodeNr = nodeName (networkNodes network ! nodeNr)++setNodeName :: NodeNr -> String -> Network g n e -> Network g n e+setNodeName nodeNr name network =+ network { networkNodes = insert nodeNr (node { nodeName = name }) (networkNodes network) }+ where node = networkNodes network ! nodeNr++getNodePosition :: Network g n e -> NodeNr -> DoublePoint+getNodePosition network nodeNr = nodePosition (networkNodes network ! nodeNr)++setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e+setNodePosition nodeNr position network =+ network { networkNodes = insert nodeNr (node { nodePosition = position }) (networkNodes network) }+ where node = networkNodes network ! nodeNr++getNodeNameAbove :: Network g n e -> NodeNr -> Bool+getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network ! nodeNr)++setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e+setNodeNameAbove nodeNr nameAbove network =+ network { networkNodes = insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) }+ where node = networkNodes network ! nodeNr++getNodeShape :: Network g n e -> NodeNr -> ShapeName+getNodeShape network nodeNr = nodeShape (networkNodes network ! nodeNr)++setNodeShape :: NodeNr -> ShapeName -> Network g n e -> Network g n e+setNodeShape nodeNr shape network =+ network { networkNodes = insert nodeNr (node { nodeShape = shape })+ (networkNodes network) }+ where node = networkNodes network ! nodeNr++getNodeInfo :: Network g n e -> NodeNr -> n+getNodeInfo network nodeNr = nodeInfo (networkNodes network ! nodeNr)++setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e+setNodeInfo nodeNr info network =+ network { networkNodes = insert nodeNr (node { nodeInfo = info }) (networkNodes network) }+ where node = networkNodes network ! nodeNr++getNameAbove :: Node a -> Bool+getNameAbove node = nodeNameAbove node++getName :: Node a -> String+getName node = nodeName node++getShape :: Node a -> ShapeName+getShape node = nodeShape node++getPosition :: Node a -> DoublePoint+getPosition node = nodePosition node++getInfo :: Node a -> a+getInfo node = nodeInfo node++-- | Set whether the name should appear above (True) or below (False) the node+setNameAbove :: Bool -> Node a -> Node a+setNameAbove above node = node { nodeNameAbove = above }++setName :: String -> Node a -> Node a+setName name node = node { nodeName = name }++setShape :: ShapeName -> Node a -> Node a+setShape s node = node { nodeShape = s }++setPosition :: DoublePoint -> Node a -> Node a+setPosition position node = node { nodePosition = position }++setInfo :: a -> Node a -> Node a+setInfo info node = node { nodeInfo = info }++-- | Get the next unused node number+getUnusedNodeNr :: Network g n e -> NodeNr+getUnusedNodeNr network | List.null used = 1+ | otherwise = maximum used + 1+ where+ used = keys (networkNodes network)++-- | Get the next unused edge number+getUnusedEdgeNr :: Network g n e -> EdgeNr+getUnusedEdgeNr network | List.null used = 1+ | otherwise = maximum used + 1+ where+ used = keys (networkEdges network)++-- | Get the node numbers of the parents of a given node+getParents :: Network g n e -> NodeNr -> [NodeNr]+getParents network child =+ [ parent+ | edge <- getEdges network+ , edgeTo edge == child+ , let parent = edgeFrom edge+ ]++type ParentMap = IntMap.IntMap [NodeNr]++-- | getParents is quite expensive (see above) and so+-- we store the parent relationship in an IntMap+getParentMap :: Network g n e -> ParentMap+getParentMap network =+ IntMap.fromList+ [ (nodeNr, getParents network nodeNr)+ | nodeNr <- getNodeNrs network+ ]++-- | Get the node numbers of the children of a given node+getChildren :: Network g n e -> NodeNr -> [NodeNr]+getChildren network parent =+ [ child+ | edge <- getEdges network+ , edgeFrom edge == parent+ , let child = edgeTo edge+ ]+++-- | Get node with given index, raises exception if node number does not exist+getNode :: NodeNr -> Network g n e -> Node n+getNode nodeNr network+ | member nodeNr nodesMap = nodesMap ! nodeNr+ | otherwise = internalError "Network" "getNode" "illegal node number"+ where+ nodesMap = networkNodes network++-- | Get edge with given index, raises exception if edge number does not exist+getEdge :: EdgeNr -> Network g n e -> Edge e+getEdge edgeNr network = networkEdges network ! edgeNr++-- | Get all of the nodes in the network+getNodes :: Network g n e -> [Node n]+getNodes network = elems (networkNodes network)++-- | Get all of the edges in the network+getEdges :: Network g n e -> [Edge e]+getEdges network = elems (networkEdges network)++-- | Get all of the node numbers in the network+getNodeNrs :: Network g n e -> [NodeNr]+getNodeNrs network = keys (networkNodes network)++getCanvasSize :: Network g n e -> (Double, Double)+getCanvasSize network = networkCanvasSize network++getGlobalInfo :: Network g n e -> g+getGlobalInfo network = networkInfo network++-- | Find the number of an edge given start and end node number+findEdge :: NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Maybe EdgeNr+findEdge fromNodeNr fromPort toNodeNr toPort network =+ let hits = IntMap.filter+ (\edge ->+ sameFromAndTo (Edge { edgeFrom = fromNodeNr+ , portFrom = fromPort+ , edgeTo = toNodeNr+ , portTo = toPort+ , edgeVia = undefined+ , edgeInfo = undefined }) edge+ || sameFromAndTo (Edge { edgeFrom = toNodeNr+ , portFrom = toPort+ , edgeTo = fromNodeNr+ , portTo = fromPort+ , edgeVia = undefined+ , edgeInfo = undefined }) edge)+ (networkEdges network)+ in case IntMap.keys hits of+ [key] -> Just key+ _ -> Nothing++-- | Find node numbers given a node name+findNodeNrsByName :: String -> Network g n e -> [NodeNr]+findNodeNrsByName theNodeName network =+ [ nodeNr+ | nodeNr <- getNodeNrs network+ , getNodeName network nodeNr == theNodeName+ ]++-- | Get a list of pairs where each pair contains a node number and the corresponding node+getNodeAssocs :: Network g n e -> [(NodeNr, Node n)]+getNodeAssocs network = assocs (networkNodes network)++setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e+setNodeAssocs nodeAssocs network =+ network { networkNodes = IntMap.fromList nodeAssocs }++-- | Get a list of pairs where each pair contains a edge number and the corresponding edge+getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)]+getEdgeAssocs network = assocs (networkEdges network)++setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e+setEdgeAssocs edgeAssocs network =+ network { networkEdges = IntMap.fromList edgeAssocs }++-- | Check if a network is empty. A network is empty is it has no nodes.+isEmpty :: Network g n e -> Bool+isEmpty = IntMap.null . networkNodes++-- | Create a string that describes the network+dumpNetwork :: InfoKind e g => Network g String e -> String+dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network)++-- | Test for existence of a node number+nodeExists :: NodeNr -> Network g n e -> Bool+nodeExists nodeNr network =+ member nodeNr (networkNodes network)++-- | Test for existence of an edge number+edgeExists :: EdgeNr -> Network g n e -> Bool+edgeExists edgeNr network =+ member edgeNr (networkEdges network)++{-----------------------------------+ Functions that change the network+ -----------------------------------}++-- | Add a node to the network+addNode :: InfoKind n g+ => ShapeName -- ^ the current shape's name+ -> Palette n -- ^ the palette+ -> Network g n e -- ^ the network to add the node to+ -> (NodeNr, Network g n e) -- ^ the number of the new node and+ -- the extended network+addNode shape palette network =+ addNodeEx ("Node " ++ show nodeNr)+ (DoublePoint 0.0 0.0)+ True+ shape+ blank+ network+ where+ nodeNr = getUnusedNodeNr network+ palette' = shapes palette+++addNodes :: InfoKind n g => ShapeName -> Palette n -> Int -> Network g n e -> ([NodeNr], Network g n e)+addNodes _ _ 0 network = ([], network)+addNodes shapeName palette n network1 =+ let (nodeNr, network2) = addNode shapeName palette network1+ (nodeNrs, network3) = addNodes shapeName palette (n-1) network2+ in (nodeNr:nodeNrs, network3)++addNodeEx :: InfoKind n g =>+ String -> DoublePoint -> Bool -> ShapeName -> n+ -> Network g n e -> (NodeNr, Network g n e)+addNodeEx name position labelAbove shape info network =+ ( nodeNr+ , network { networkNodes = insert nodeNr node (networkNodes network) }+ )+ where+ nodeNr = getUnusedNodeNr network+ node = constructNode name position labelAbove shape info++addExistingNode :: InfoKind n g => Node n -> Network g n e -> (NodeNr, Network g n e)+addExistingNode node network = + ( nodeNr+ , network { networkNodes = insert nodeNr node' (networkNodes network) }+ )+ where+ nodeNr = getUnusedNodeNr network+ node' = setName ("Node " ++ show nodeNr) node++-- | Add an edge to the network. The probability table of the target node is updated:+-- a dimension is added and all values are zeroed.+addEdge :: InfoKind e g => Palette n -> NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Network g n e+addEdge palette fromNodeNr fromPort toNodeNr toPort network+ | any (sameFromAndTo edge) edgesList || -- prohibit double edges + any (sameFromAndTo (reverseEdge edge)) edgesList || -- prohibit edges in opposite direction+ anyPortAlreadyUsed edge edgesList -- only one connection per port is allowed+ || (fromNodeNr, fromPort) == (toNodeNr, toPort) -- prohibit edges from a port to itself+ = network+ | otherwise =+ let edgeNr = getUnusedEdgeNr network+ networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }+ in networkPlusEdge+ where+ edge = Edge { edgeFrom = fromNodeNr, portFrom = fromPort+ , edgeTo = toNodeNr, portTo = toPort+ , edgeVia = if fromNodeNr /= toNodeNr then [] else [point2EdgeInNode palette fromNodeNr fromPort toPort network]+ , edgeInfo = blank }+ edgesList = elems (networkEdges network)++addEdges :: InfoKind e g => Palette n -> [( (NodeNr, PortName), (NodeNr, PortName) )]+ -> Network g n e -> Network g n e+addEdges palette edgeTuples network =+ foldr (\((fromNr, fromMPort), (toNr, toMPort)) net -> addEdge palette fromNr fromMPort toNr toMPort net) + network edgeTuples++-- | Insert a new 'via' control point in the middle of an edge.+newViaEdge :: EdgeNr -> ViaNr -> DoublePoint+ -> Network g n e -> Network g n e+newViaEdge edgeNr viaNr point network =+ network { networkEdges = adjust (\e->e{ edgeVia= take viaNr (edgeVia e)+ ++[point]+ ++drop viaNr (edgeVia e) })+ edgeNr+ (networkEdges network) }++-- | Remove node with given index, raises exception if node number does not exist.+-- This function also removes all edges that start or end in this node.+removeNode :: NodeNr -> Network g n e -> Network g n e+removeNode nodeNr network =+ let involvedEdges = [ i+ | (i, edge) <- getEdgeAssocs network+ , edgeFrom edge == nodeNr || edgeTo edge == nodeNr+ ]+ networkWithoutEdges = foldr removeEdge network involvedEdges+ networkWithoutNode = networkWithoutEdges { networkNodes = delete nodeNr (networkNodes networkWithoutEdges) }+ in networkWithoutNode++-- | Remove an edge from the network. The probability table of the target node is updated:+-- the corresponding dimension is removed and all values are zeroed.+-- An exception is raised if edge number does not exist.+removeEdge :: EdgeNr -> Network g n e -> Network g n e+removeEdge edgeNr network =+ network { networkEdges = delete edgeNr (networkEdges network) }++-- | Remove all edges from the network. The probability tables of all node are zeroed.+removeAllEdges :: Network g n e -> Network g n e+removeAllEdges network =+ let networkWithoutEdges = network { networkEdges = IntMap.empty }+ in networkWithoutEdges++-- | Remove a control point from an edge.+removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e+removeVia edgeNr viaNr network =+ let remove n e = e { edgeVia = take n (edgeVia e)+ ++ drop (n+1) (edgeVia e) } in+ network { networkEdges = adjust (remove viaNr)+ edgeNr (networkEdges network) }++setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e+setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize }++setGlobalInfo :: g -> Network g n e -> Network g n e+setGlobalInfo info network = network { networkInfo = info }++{-----------------------------------+ Local functions+ -----------------------------------}++{- | Checks if two edges are equal. Equality in edges is: + * if the edges have information of ports then the edges are equal when the pairs+ (node,port) from and to of the two edges are the same+ * otherwise the edges are equal if the from and to Nodes are the same+-}+sameFromAndTo :: Edge e -> Edge e -> Bool+sameFromAndTo edge1 edge2 =+ getFullPortFrom edge1 == getFullPortFrom edge2 && getFullPortTo edge1 == getFullPortTo edge2 -- equality on nodes and ports++reverseEdge :: Edge e -> Edge e+reverseEdge edge =+ edge { edgeFrom = edgeTo edge + , portFrom = portTo edge+ , edgeTo = edgeFrom edge+ , portTo = portFrom edge}++-- | Avoid the introduction of connections on ports that already are used.+-- So only one connection per port is allowed.+anyPortAlreadyUsed :: Edge e -> [Edge e] -> Bool+anyPortAlreadyUsed edge edgesList = + (edgeFrom edge, portFrom edge) `elem` portsList+ || (edgeTo edge, portTo edge) `elem` portsList+ where portsList = concatMap f edgesList+ f e = [(edgeFrom e, portFrom e), (edgeTo e, portTo e)]++-- | Update node with given number by applying the function to it+-- Dangerous (wrt network consistency, do not export)+updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e+updateNode nodeNr nodeFunction network =+ let node = getNode nodeNr network in+ network { networkNodes = insert nodeNr (nodeFunction node)+ (networkNodes network) }++updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e+updateEdge edgeNr edgeFunction network =+ network { networkEdges = adjust edgeFunction edgeNr+ (networkEdges network) }++updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e+updateVia edgeNr viaNr v network =+ network { networkEdges =+ adjust (\e-> e { edgeVia = take viaNr (edgeVia e)+ ++[v]++drop (viaNr+1) (edgeVia e) })+ edgeNr (networkEdges network) }++edgeConnectedOnPort :: Network g n e -> NodeNr -> PortName -> Maybe EdgeNr+edgeConnectedOnPort network nodeNr port = + case IntMap.keys (IntMap.filter f (networkEdges network) ) of+ [edgeNr] -> Just edgeNr+ _ -> Nothing+ where f :: Edge e -> Bool+ f edge = + getFullPortFrom edge == (nodeNr, port)+ || getFullPortTo edge == (nodeNr, port)++otherExtremeOfEdgeConnectedOnPort :: Network g n e -> NodeNr -> PortName+ -> Maybe (NodeNr, PortName)+otherExtremeOfEdgeConnectedOnPort network nodeNr port =+ case edgeConnectedOnPort network nodeNr port of+ Just edgeNr | getFullPortFrom (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortTo (getEdge edgeNr network)+ Just edgeNr | getFullPortTo (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortFrom (getEdge edgeNr network)+ _ -> Nothing++point2EdgeInNode :: Palette n -> NodeNr -> PortName -> PortName -> Network g n e -> DoublePoint+point2EdgeInNode palette nodeNr fromPort toPort network =+ case getPorts palette network nodeNr of+ Just ports ->+ case (Prelude.lookup fromPort ports, Prelude.lookup toPort ports) of+ (Just fromPortPos, Just toPortPos) ->+ g (portZone (fromPort,fromPortPos)) (portZone (toPort,toPortPos))+ _ -> error "unexpected situation"+ Nothing -> f 1 1+ where g Ztop Ztop = top + g Zbottom Zbottom = bottom + g Zleft Zleft = left+ g Zright Zright = right+ g Ztop Zbottom = right+ g Zbottom Ztop = right+ g Zleft Zright = top+ g Zright Zleft = top+ g Ztop Zleft = q2+ g Ztop Zright = q1+ g Zbottom Zleft = q3+ g Zbottom Zright = q4+ g Zleft Ztop = q2+ g Zleft Zbottom = q3+ g Zright Ztop = q1+ g Zright Zbottom = q4++ param = 2.0+ f x y = translate (getNodePosition network nodeNr) $ DoublePoint (x * param) (y * param)++ top = f 0 (-1) + bottom = f 0 1+ left = f (-1) 0+ right = f 1 0+ q1 = f 1 (-1)+ q2 = f (-1) (-1)+ q3 = f (-1) 1+ q4 = f 1 1++isPrincipalPort :: Palette n -> Network g n e -> NodeNr -> PortName -> Bool+isPrincipalPort palette network nodeNr port =+ maybe False f $ getPorts palette network nodeNr+ where+ f ((port2,_):_) = port2 == port+ f _ = False++getPorts :: Palette n -> Network g n e -> NodeNr -> Maybe Ports+getPorts palette network nodeNr =+ case getSymbol (getNodeShape network nodeNr) palette of+ Just (_,ports,_) -> Just ports+ _ -> Nothing++getPort :: Palette n -> Network g n e -> (NodeNr,PortName) -> Maybe Port+getPort palette network (nodeNr,portName) =+ case getSymbol (getNodeShape network nodeNr) palette of+ Just (_,ports,_) ->+ case Prelude.lookup portName ports of+ Just portPosition -> Just (portName, portPosition)+ _ -> Nothing+ _ -> Nothing+
+ src/NetworkControl.hs view
@@ -0,0 +1,534 @@+module NetworkControl+ ( createNode, selectNode+ , createEdge, selectEdge+ , createVia, selectVia+ , selectPort+ , createMapping+ , selectNothing, selectMultiple+ , pickupNode, dragNode, dropNode+ , pickupVia, dragVia, dropVia+ , pickupMultiple, dragMultiple, dropMultiple+ , pickupArea, dragArea, dropArea+ , deleteSelection+ , changeNamePosition+ , changeNodeShape+ , renameNode, reinfoNodeOrEdge+ , changeGlobalInfo+ ) where+ +{- pickupX functions with X belonging to {Node, Edge, Via, Area, Multiple} do+ 1 - setDragging on+ 2 - selects X+-}++ +import State+import StateUtil+import Network+import NetworkView (edgeContains)+import Document+import INRule+import INRules+import Common+import CommonIO+import Math +import Shape+import Ports+import qualified PersistentDocument as PD +import InfoKind+import Text.Parse as Parse+import Data.Char (isSpace)++import Graphics.UI.WX hiding (Selection)+import Graphics.UI.WXCore++++changeNamePosition :: Bool -> State g n e -> IO ()+changeNamePosition above state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas -> + do{ PD.updateDocument "move label"+ (updateSelNetwork + (updateNode nodeNr + (setNameAbove above)) canvas) pDoc+ ; repaintAll state+ }+ _ -> return ()+ }++changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO ()+changeNodeShape shapename info state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas -> + do{ PD.updateDocument "change shape"+ (updateSelNetwork + (updateNode nodeNr + (setInfo info . setShape shapename)) canvas) pDoc+ ; repaintAll state+ }+ _ -> return ()+ }++deleteSelection :: State g n e -> IO ()+deleteSelection state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas -> + do{ PD.updateDocument "delete node"+ ( setSelection NoSelection+ . removeMappingElemWithNode canv nodeNr + . updateSelNetwork (removeNode nodeNr) canvas+ ) pDoc+ ; repaintAll state+ }+ EdgeSelection canv edgeNr | canv == canvas -> + do{ PD.updateDocument "delete edge"+ ( setSelection NoSelection+ . updateSelNetwork (removeEdge edgeNr) canvas+ ) pDoc+ ; repaintAll state+ }+ ViaSelection canv edgeNr viaNr | canv == canvas ->+ do{ PD.updateDocument "delete control point"+ ( setSelection NoSelection+ . updateSelNetwork (removeVia edgeNr viaNr) canvas+ ) pDoc+ ; repaintAll state+ }+ MultipleSelection canv area nodeNrs viaNrs | canv == canvas ->+ do{ PD.updateDocument "delete multiple selection"+ ( setSelection NoSelection+ . updateSelNetwork (foldr (\edgeNr r -> removeNode edgeNr . r) id nodeNrs) canvas+ ) pDoc+ ; repaintAll state+ }+ _ -> return ()+ }+ +createNode :: InfoKind n g => DoublePoint -> State g n e -> IO ()+createNode mousePoint state = + do{ pDoc <- getDocument state+ ; shapeName <- getCurrentShape state+ ; canvas <- getActiveCanvas state+ ; doc1 <- PD.getDocument pDoc ++ ; let palette = getPalette doc1+ (nodeNr, doc2) = updateSelNetworkEx + (setNewPosition . addNode shapeName palette) + canvas doc1+ doc3 = setSelection (NodeSelection canvas nodeNr Nothing) doc2+ ; PD.setDocument ("add node on " ++ show' canvas) doc3 pDoc + ; repaintAll state+ }+ where setNewPosition (nodeNr, newNet) = + (nodeNr, updateNode nodeNr ( setPosition mousePoint) newNet )++selectNothing :: State g n e -> IO ()+selectNothing state = + do{ pDoc <- getDocument state+ ; PD.superficialUpdateDocument (setSelection NoSelection) pDoc+ ; repaintAll state+ }++selectEdge :: Int -> State g n e -> IO ()+selectEdge edgeNr state = + do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument (setSelection (EdgeSelection canvas edgeNr)) pDoc+ ; repaintAll state+ }++createEdge :: (InfoKind e g) => NodeNr -> PortName -> NodeNr -> PortName -> State g n e -> IO ()+createEdge fromNodeNr fromPort toNodeNr toPort state =+ do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; doc <- PD.getDocument pDoc+ ; PD.updateDocument "add edge"+ ( setSelection (NodeSelection canvas fromNodeNr $ Just fromPort)+ . updateSelNetwork (addEdge (getPalette doc) fromNodeNr fromPort toNodeNr toPort)+ canvas ) pDoc+ ; repaintAll state+ } ++createMapping :: RuleName -- ^ rule to add the mapping to+ -> NodeNr -- ^ LHS node number+ -> NodeNr -- ^ RHS node number+ -> State g n e -> IO ()+createMapping rule nNrL nNrR state =+ do{ pDoc <- getDocument state+ ; PD.updateDocument ("add mapping to rule " ++ rule)+ (updateRules + $ updateRule rule + $ updateMapping + $ addMapping (nNrL, nNrR)+ ) pDoc+ ; repaintAll state+ }++createVia :: DoublePoint -> State g n e -> IO ()+createVia mousepoint state =+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ ; case getSelection doc of+ EdgeSelection canv edgeNr | canv == canvas ->+ do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network)+ $ \viaNr->+ do{ PD.updateDocument "add control point to edge"+ ( setSelection (ViaSelection canvas edgeNr viaNr)+ . updateSelNetwork (newViaEdge edgeNr viaNr mousepoint) canvas+ ) pDoc+ ; repaintAll state+ }+ }+ _ -> return ()+ }++selectVia :: Int -> Int -> State g n e -> IO ()+selectVia edgeNr viaNr state = + do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument (setSelection (ViaSelection canvas edgeNr viaNr))+ pDoc+ ; repaintAll state+ }++pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()+pickupVia edgeNr viaNr mousePoint state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr+ ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state+ ; selectVia edgeNr viaNr state+ }+ +selectNode :: Int -> State g n e -> IO ()+selectNode nodeNr state = selectPort nodeNr Nothing state++selectPort :: Int -> Maybe PortName -> State g n e -> IO ()+selectPort nodeNr mPort state = + do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument (setSelection $ NodeSelection canvas nodeNr mPort) pDoc+ ; repaintAll state+ }++pickupNode :: Int -> Maybe PortName -> DoublePoint -> State g n e -> IO ()+pickupNode nodeNr mPort mousePoint state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ nodePos = getNodePosition network nodeNr+ ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state+ ; selectPort nodeNr mPort state+ }++dragNode :: Int -> DoublePoint -> State g n e -> IO ()+dragNode nodeNr mousePoint state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; Just (hasMoved, offset) <- getDragging state+ ; let newPosition = mousePoint `subtractDoublePoint` offset+ oldPosition = getNodePosition (selectNetwork doc canvas) nodeNr+ ; when (newPosition /= oldPosition) $+ do{ -- The first time the node is moved we have to remember+ -- the document in the undo history+ ; (if not hasMoved then PD.updateDocument "move node" + else PD.superficialUpdateDocument)+ (updateSelNetwork (updateNode nodeNr + (setPosition newPosition)) canvas ) + pDoc+ ; repaintAll state+ ; setDragging (Just (True, offset)) state + -- yes, the node has really moved + }+ }++dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()+dropNode hasMoved nodeNr offset mousePoint state = + do{ when hasMoved $+ do{ let newPosition = mousePoint `subtractDoublePoint` offset+ ; pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument+ (updateSelNetwork (updateNode nodeNr + (setPosition newPosition)) canvas) pDoc+ }+ ; repaintAll state+ ; setDragging Nothing state+ }++dragVia :: Int -> Int -> DoublePoint -> State g n e -> IO ()+dragVia edgeNr viaNr mousePoint state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; Just (hasMoved, offset) <- getDragging state+ ; let newPosition = mousePoint `subtractDoublePoint` offset+ oldPosition = (getEdgeVia (getEdge edgeNr (selectNetwork doc canvas)))!!viaNr+ ; when (newPosition /= oldPosition) $+ do{ -- The first time the point is moved we have to remember+ -- the document in the undo history+ ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument)+ (updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)+ pDoc+ ; repaintAll state+ ; setDragging (Just (True, offset)) state + -- yes, the point has really moved + }+ }++dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO ()+dropVia hasMoved edgeNr viaNr offset mousePoint state = + do{ when hasMoved $+ do{ let newPosition = mousePoint `subtractDoublePoint` offset+ ; pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument+ (updateSelNetwork (updateVia edgeNr viaNr newPosition) canvas)+ pDoc+ }+ ; repaintAll state+ ; setDragging Nothing state+ }++selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)]+ -> State g n e -> IO ()+selectMultiple area nodeNrs viaNrs state = + do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument+ (setSelection (MultipleSelection canvas area nodeNrs viaNrs))+ pDoc+ ; repaintAll state+ }++pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()+pickupMultiple _nodeNrs _viaNrs mousePoint state = + do{ setDragging (Just (False, mousePoint)) state+-- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected+ }++dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO ()+dragMultiple nodeNrs viaNrs mousePoint state = + do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ -- ; doc <- PD.getDocument pDoc+ ; Just (hasMoved, origin) <- getDragging state+ ; let offset = mousePoint `subtractDoublePoint` origin+ ; when (mousePoint /= origin) $+ do{ -- The first time the point is moved we have to remember+ -- the document in the undo history+ ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument)+ (updateSelNetwork (updateMultiple nodeNrs viaNrs offset) canvas)+ pDoc+ ; repaintAll state+ ; setDragging (Just (True, mousePoint)) state + -- yes, the point has really moved + }+ }++updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e+ -> Network g n e+updateMultiple ns vs o network =+ ( foldr (\n z-> updateNode n (offsetNode o) . z) id ns+ . foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs+ ) network+ where+ offsetNode off node = setPosition (getPosition node `translate` off) node+ offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via)+ `translate` off++dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint+ -> State g n e -> IO ()+dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state = + do{ when hasMoved $+ do{ pDoc <- getDocument state+ ; canvas <- getActiveCanvas state+ ; PD.superficialUpdateDocument+ (updateSelNetwork+ (updateMultiple nodeNrs viaNrs+ (mousePoint`subtractDoublePoint`origin)) canvas)+ pDoc+ }+ ; repaintAll state+ ; setDragging Nothing state+ }++pickupArea :: DoublePoint -> State g n e -> IO ()+pickupArea mousePoint state = + do{ setDragging (Just (False, mousePoint)) state+ ; selectMultiple (Just (mousePoint,mousePoint)) [] [] state+ }++-- dragArea is not like dragging a selection. It does not move anything.+-- It only adds items into a multiple selection.+dragArea :: DoublePoint -> State g n e -> IO ()+dragArea mousePoint state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; Just (_, origin) <- getDragging state+ ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (selectNetwork doc canvas)+ ; selectMultiple (Just (origin,mousePoint)) ns vs state+ }+ where+ itemsEnclosedWithin p0 p1 network =+ ( ( Prelude.map fst+ . Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1)+ . getNodeAssocs ) network+ , ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j))+ (Prelude.filter+ (\ (_,v)-> enclosedInRectangle+ v p0 p1)+ (zip [0..] (getEdgeVia e))))+ . getEdgeAssocs ) network+ )++dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO ()+dropArea _origin mousePoint state = + do{ dragArea mousePoint state -- calculate enclosure area+ ; pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; case getSelection doc of+ MultipleSelection _ _ [] [] ->+ PD.superficialUpdateDocument (setSelection NoSelection) pDoc+ MultipleSelection canv _ ns vs | canvas == canv ->+ PD.superficialUpdateDocument+ (setSelection (MultipleSelection canvas Nothing ns vs)) pDoc+ | otherwise -> + PD.superficialUpdateDocument (setSelection NoSelection) pDoc+ _ -> return ()+ ; setDragging Nothing state+ ; repaintAll state+ }+++renameNode :: Frame () -> State g n e -> IO ()+renameNode theFrame state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas ->+ do{ let oldName = getNodeName network nodeNr+ ; result <- myTextDialog theFrame SingleLine+ "Rename node" oldName True+ ; ifJust result $ \newName ->+ do{ PD.updateDocument "rename node"+ (updateSelNetwork + (updateNode nodeNr (Network.setName newName)) canvas) pDoc+ ; repaintAll state+ }+ }+ _ -> return ()+ }++reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) =>+ Frame () -> State g n e -> IO ()+reinfoNodeOrEdge theFrame state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ ; case getSelection doc of+ NodeSelection canv nodeNr _ | canv == canvas ->+ do{ let oldInfo = getNodeInfo network nodeNr+ ; result <- myTextDialog theFrame MultiLine+ "Edit node info" (show oldInfo) True+ ; ifJust result $ \newInfo ->+ case Parse.runParser Parse.parse newInfo of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s)+ ; case check (getNodeName network nodeNr)+ (getGlobalInfo network) x of+ [] -> return ()+ e -> errorDialog theFrame "Validity warning"+ ("Validity check fails:\n"+ ++unlines e)+ ; PD.updateDocument "edit node info"+ (updateSelNetwork + (updateNode nodeNr (setInfo x)) canvas) pDoc+ ; repaintAll state+ }+ (Left err, s) -> errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ }+ EdgeSelection canv edgeNr | canv == canvas ->+ do{ let oldInfo = getEdgeInfo (getEdge edgeNr network)+ ; result <- myTextDialog theFrame MultiLine+ "Edit edge info" (show oldInfo) True+ ; ifJust result $ \newInfo ->+ case Parse.runParser Parse.parse newInfo of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s)+ -- ; case check (getNodeName network nodeNr)+ -- (getGlobalInfo network) x of+ -- [] -> return ()+ -- e -> errorDialog theFrame "Validity warning"+ -- ("Validity check fails:\n"+ -- ++unlines e)+ ; PD.updateDocument "edit edge info"+ (updateSelNetwork + (updateEdge edgeNr (setEdgeInfo x)) canvas) pDoc+ ; repaintAll state+ }+ (Left err, s) -> errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ }+ _ -> return ()+ }++changeGlobalInfo :: (Show g, Parse g) => Frame () -> State g n e -> IO ()+changeGlobalInfo theFrame state = + do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; canvas <- getActiveCanvas state+ ; let network = selectNetwork doc canvas+ ; let info = show (getGlobalInfo network)+ ; result <- myTextDialog theFrame MultiLine "Edit global info" info True+ ; ifJust result $ \newInfo->+ case Parse.runParser Parse.parse newInfo of+ (Right x, s) ->+ do{ when (not (null s || all isSpace s)) $+ errorDialog theFrame "Edit warning"+ ("Excess text after parsed value."+ ++"\nRemaining text: "++s)+ ; PD.updateDocument "edit global info"+ (updateSelNetwork (setGlobalInfo x) canvas) pDoc+ ; repaintAll state -- no visible change?+ }+ (Left err, s) -> errorDialog theFrame "Edit warning"+ ("Cannot parse entered text."+ ++"\nReason: "++err+ ++"\nRemaining text: "++s)+ }+
+ src/NetworkFile.hs view
@@ -0,0 +1,465 @@+{-# OPTIONS -fallow-undecidable-instances #-}++module NetworkFile where++import Network+import Math+import Common+import Colors+import Shape+import InfoKind+import Ports++import Text.XML.HaXml.Types+import Text.XML.HaXml.Escape+import Text.XML.HaXml.Posn (noPos)+import Text.XML.HaXml.Parse+import Text.XML.HaXml.XmlContent as XML+import Text.XML.HaXml.Combinators (replaceAttrs)+import Text.XML.HaXml.Verbatim+import Text.PrettyPrint.HughesPJ+import qualified Text.XML.HaXml.Pretty as Pretty+import Data.Char+import Data.Maybe+import Monad(when)+import Data.List(nub,isPrefixOf)++-- | Print the network data structure to an XML text+toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ Network g n e -> String+toString network = render . Pretty.document $+ Document (Prolog Nothing [] Nothing []) emptyST (f (toContents network)) []+ where+ f [CElem e _] = e+ f _ = error "bad" -- shouldn't happen++-- | Parses a string to the network data structure+-- Returns either an error message (Left) or the network,+-- a list of warnings (Right) and a boolean indicating whether+-- the file was an old Dazzle file+fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>+ String -> Either String (Network g n e, [String], Bool)+fromString xml =+ case xmlParse' "input file" xml of+ Left err -> Left err -- lexical or initial (generic) parse error+ Right (Document _ _ e _) ->+ case runParser parseContents [CElem e noPos] of+ (Left err, _) -> Left err -- secondary (typeful) parse error+ (Right v, _) -> Right (v,[],False)++{-+-- non-XML output+toStringShow :: (Show g, Show n, Show e) => Network g n e -> String+toStringShow network =+ show ( getNodeAssocs network+ , getEdgeAssocs network+ , getCanvasSize network+ , getGlobalInfo network+ )++fromStringShow :: (Read g, InfoKind n g, InfoKind e g) =>+ String -> Either String (Network g n e)+fromStringShow txt =+ case reads txt of+ ((tuple,[]):_) ->+ let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple+ in Right ( setNodeAssocs nodeAssocs+ . setEdgeAssocs edgeAssocs+ . setCanvasSize canvasSize+ $ Network.empty globalInfo undefined undefined+ )+ _ -> Left "File is not a " ++ toolName ++ " network"+-}++---------------------------------------------------------+-- Internal type isomorphic to (index,value) pairs+-- (but permits instances of classes)+---------------------------------------------------------+data AssocN n = AssocN Int (Node n)+deAssocN :: AssocN n -> (Int,Node n)+deAssocN (AssocN n v) = (n,v)+data AssocE e = AssocE Int (Edge e)+deAssocE :: AssocE e -> (Int,Edge e)+deAssocE (AssocE n v) = (n,v)++---------------------------------------------------------+-- Convert our data type to/from an XML tree+---------------------------------------------------------+instance HTypeable (Network g n e) where+ toHType _ = Defined "Network" [] [Constr "Network" [] []]+instance (InfoKind n g, InfoKind e g, XmlContent g) =>+ XmlContent (Network g n e) where+ toContents network = + [CElem (Elem "Network"+ [ mkAttr "Width" (show width)+ , mkAttr "Height" (show height)+ ]+ [ makeTag "Info" (toContents netInfo)+ , makeTag "Nodes" (concatMap toContents nodeAssocs)+ , makeTag "Edges" (concatMap toContents edgeAssocs)+ ]) () ]+ where+ nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network+ edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network+ (width, height) = getCanvasSize network+ netInfo = getGlobalInfo network+ parseContents = do+ { (p, e@(Elem _ [("Width",w),("Height",h)] cs)) <- posnElement ["Network"]+ ; reparse cs+ ; w' <- attr2value w+ ; h' <- attr2value h+ ; i <- inElement "Info" $ parseContents+ ; ns <- inElement "Nodes" $ many parseContents+ ; es <- inElement "Edges" $ many parseContents+ ; networkValid ns es+ ; return ( setCanvasSize (w',h')+ . setNodeAssocs (map deAssocN ns)+ . setEdgeAssocs (map deAssocE es)+ $ Network.empty i undefined undefined)+ }++attr2value :: (Read a) => AttValue -> XMLParser a+attr2value (AttValue [Left n]) = return (read n)+attr2value (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)++peekAttributes :: String -> XMLParser [(String,AttValue)]+peekAttributes t =+ do{ (p, e@(Elem _ as _)) <- posnElement [t]+ ; reparse [CElem e p]+ ; return as+ }++instance HTypeable (AssocN n) where+ toHType _ = Defined "Node" [] [Constr "Node" [] []]+instance (InfoKind n g) => XmlContent (AssocN n) where+ toContents (AssocN n node) =+ concatMap (replaceAttrs [("id",'N':show n)]) (toContents node)+ parseContents = do+ { [("id",n)] <- peekAttributes "Node"+ ; n' <- num n+ ; node <- parseContents+ ; return (AssocN n' node)+ }+ where num (AttValue [Left ('N':n)]) = return (read n)+ num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)++instance HTypeable (AssocE e) where+ toHType _ = Defined "Edge" [] [Constr "Edge" [] []]+instance (InfoKind e g) => XmlContent (AssocE e) where+ toContents (AssocE n edge) =+ concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge)+ parseContents = do+ { [("id",n)] <- peekAttributes "Edge"+ ; n' <- num n+ ; edge <- parseContents+ ; return (AssocE n' edge)+ }+ where num (AttValue [Left ('E':n)]) = return (read n)+ num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)++instance HTypeable (Node n) where+ toHType _ = Defined "Node" [] [Constr "Node" [] []]+instance (InfoKind n g) => XmlContent (Node n) where+ toContents node =+ [ makeTag "Node"+ (toContents (getPosition node) +++ [ escapeString "Name" (getName node)+ , simpleString "LabelAbove" (show (getNameAbove node))+ , escapeString "Shape" (getShape node)+ , makeTag "Info" (toContents (getInfo node))+ ])+ ]+ parseContents = do+ { inElement "Node" $ do+ { p <- parseContents -- position+ ; n <- inElement "Name" $ XML.text+ ; a <- inElement "LabelAbove" $ fmap read XML.text+ ; s <- inElement "Shape" $ XML.text+ ; i <- inElement "Info" $ parseContents+ ; return (constructNode n p a s i)+ }+ }++instance HTypeable DoublePoint where+ toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []]+instance XmlContent DoublePoint where+ toContents (DoublePoint x y) = + [ CElem (Elem "Position"+ [ mkAttr "X" (show x)+ , mkAttr "Y" (show y)+ ] []) () ]+ parseContents = do+ { (p, e@(Elem _ [("X",x),("Y",y)] [])) <- posnElement ["Position"]+ ; x' <- attr2value x+ ; y' <- attr2value y+ ; return (DoublePoint x' y')+ }++instance HTypeable (Edge e) where+ toHType _ = Defined "Edge" [] [Constr "Edge" [] []]+instance InfoKind e g => XmlContent (Edge e) where+ toContents edge =+ [ makeTag "Edge"+ [ simpleString "From" (show (getEdgeFrom edge))+ , escapeString "PortFrom" (getPortFrom edge)+ , simpleString "To" (show (getEdgeTo edge))+ , escapeString "PortTo" (getPortTo edge)+ , makeTag "Via" (concatMap toContents (getEdgeVia edge))+ , makeTag "Info" (toContents (getEdgeInfo edge))+ ]+ ]+ where maybeSnd = maybe Nothing (Just . snd)+ parseContents = do+ { inElement "Edge" $ do+ { f <- inElement "From" $ fmap read XML.text+ ; q <- inElement "PortFrom" $ XML.text+ ; t <- inElement "To" $ fmap read XML.text+ ; r <- inElement "PortTo" $ XML.text+ ; v <- inElement "Via" $ many parseContents+ ; i <- inElement "Info" $ parseContents+ ; return (constructEdge f q t r v i)+ }+ }++instance HTypeable Colour where+ toHType v = Defined "Colour" []+ [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]+ where (RGB aa ab ac) = v+instance XmlContent Colour where+ parseContents = do+ { (p, e@(Elem _ [("R",r),("G",g),("B",b)] [])) <- posnElement ["RGB"]+ ; r' <- attr2value r+ ; g' <- attr2value g+ ; b' <- attr2value b+ ; return (RGB r' g' b')+ }+ toContents v@(RGB aa ab ac) =+ [CElem (Elem (showConstr 0 (toHType v))+ [ mkAttr "R" (show aa)+ , mkAttr "G" (show ab)+ , mkAttr "B" (show ac)+ ] []) () ]++{- derived by DrIFT -}+instance HTypeable Shape where+ toHType v =+ Defined "Shape" []+ [Constr "Circle" [] [toHType aa,toHType ab],+ Constr "Polygon" [] [toHType ac,toHType ad],+ Constr "Lines" [] [toHType ae,toHType af],+ Constr "Points" [] [toHType ag,toHType ah],+ Constr "Rectangle" [] [toHType ai,toHType aj,toHType ak],+ Constr "Arc" []+ [toHType al,toHType am,toHType an,toHType ao,toHType ap]+ ,Constr "Ellipse" [] [toHType aq,toHType ar,toHType as,toHType at],+ Constr "EllipticArc" []+ [toHType au,toHType av,toHType aw,toHType ax,toHType ay,toHType az]+ ,Constr "RoundRec" [] [toHType aA,toHType aB,toHType aC,toHType aD]+ ,Constr "Text" [] [toHType aE,toHType aF],+ Constr "Composite" [] [toHType aG],+ Constr "TextInEllipse" [] [toHType aH,toHType aI]]+ where+ (Circle aa ab) = v+ (Polygon ac ad) = v+ (Lines ae af) = v+ (Points ag ah) = v+ (Rectangle ai aj ak) = v+ (Arc al am an ao ap) = v+ (Ellipse aq ar as at) = v+ (EllipticArc au av aw ax ay az) = v+ (RoundRec aA aB aC aD) = v+ (Text aE aF) = v+ (Composite aG) = v+ (TextInEllipse aH aI) = v++instance XmlContent Shape where+ parseContents = do+ { e@(Elem t _ _) <- elementWith (flip isPrefixOf) ["TextInEllipse","Text","RoundRec","Rectangle","Polygon","Points","Lines","EllipticArc","Ellipse","Composite","Circle","Arc"]+ ; case t of+ _ | "TextInEllipse" `isPrefixOf` t -> interior e $+ return TextInEllipse `apply` parseContents `apply` parseContents+ | "Text" `isPrefixOf` t -> interior e $+ return Text `apply` parseContents `apply` parseContents+ | "RoundRec" `isPrefixOf` t -> interior e $+ return RoundRec `apply` parseContents `apply` parseContents+ `apply` parseContents `apply` parseContents+ | "Rectangle" `isPrefixOf` t -> interior e $+ return Rectangle `apply` parseContents `apply` parseContents+ `apply` parseContents+ | "Polygon" `isPrefixOf` t -> interior e $+ return Polygon `apply` parseContents `apply` parseContents+ | "Points" `isPrefixOf` t -> interior e $+ return Points `apply` parseContents `apply` parseContents+ | "Lines" `isPrefixOf` t -> interior e $+ return Lines `apply` parseContents `apply` parseContents+ | "EllipticArc" `isPrefixOf` t -> interior e $+ return EllipticArc `apply` parseContents `apply` parseContents+ `apply` parseContents `apply` parseContents+ `apply` parseContents `apply` parseContents+ | "Ellipse" `isPrefixOf` t -> interior e $+ return Ellipse `apply` parseContents `apply` parseContents+ `apply` parseContents `apply` parseContents+ | "Composite" `isPrefixOf` t -> interior e $ fmap Composite parseContents+ | "Circle" `isPrefixOf` t -> interior e $+ return Circle `apply` parseContents `apply` parseContents+ | "Arc" `isPrefixOf` t -> interior e $+ return Arc `apply` parseContents `apply` parseContents+ `apply` parseContents `apply` parseContents `apply` parseContents+ }+ toContents v@(Circle aa ab) =+ [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,+ toContents ab])]+ toContents v@(Polygon ac ad) =+ [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,+ toContents ad])]+ toContents v@(Lines ae af) =+ [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,+ toContents af])]+ toContents v@(Points ag ah) =+ [mkElemC (showConstr 3 (toHType v)) (concat [toContents ag,+ toContents ah])]+ toContents v@(Rectangle ai aj ak) =+ [mkElemC (showConstr 4 (toHType v)) (concat [toContents ai,+ toContents aj,toContents ak])]+ toContents v@(Arc al am an ao ap) =+ [mkElemC (showConstr 5 (toHType v)) (concat [toContents al,+ toContents am,toContents an,toContents ao,+ toContents ap])]+ toContents v@(Ellipse aq ar as at) =+ [mkElemC (showConstr 6 (toHType v)) (concat [toContents aq,+ toContents ar,toContents as,toContents at])]+ toContents v@(EllipticArc au av aw ax ay az) =+ [mkElemC (showConstr 7 (toHType v)) (concat [toContents au,+ toContents av,toContents aw,toContents ax,+ toContents ay,toContents az])]+ toContents v@(RoundRec aA aB aC aD) =+ [mkElemC (showConstr 8 (toHType v)) (concat [toContents aA,+ toContents aB,toContents aC,toContents aD])]+ toContents v@(Text aE aF) =+ [mkElemC (showConstr 9 (toHType v)) (concat [toContents aE,+ toContents aF])]+ toContents v@(Composite aG) =+ [mkElemC (showConstr 10 (toHType v)) (toContents aG)]+ toContents v@(TextInEllipse aH aI) =+ [mkElemC (showConstr 11 (toHType v)) (concat [toContents aH,+ toContents aI])]++{- derived by DrIFT -}+instance HTypeable ShapeStyle where+ toHType v = Defined "ShapeStyle" []+ [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]+ where (ShapeStyle aa ab ac) = v+instance XmlContent ShapeStyle where+ parseContents = do+ { inElement "ShapeStyle" $ do+ { aa <- parseContents+ ; ab <- parseContents+ ; ac <- parseContents+ ; return (ShapeStyle aa ab ac)+ }+ }+ toContents v@(ShapeStyle aa ab ac) =+ [mkElemC (showConstr 0 (toHType v))+ (concat [toContents aa, toContents ab, toContents ac])]+++---- UTILITY FUNCTIONS++-- Abbreviations+makeTag :: String -> [Content i] -> Content i+makeTag name children = CElem (Elem name [] children) undefined++tagWithId :: String -> String -> [Content i] -> Content i+tagWithId name identity children =+ CElem (Elem name [("id", AttValue [Left identity])] children) undefined++-- | A simple string contains no spaces or unsafe characters+simpleString :: String -> String -> Content i+simpleString tag value =+ CElem (Elem tag [] [ CString False value undefined ]) undefined++-- | The string value may contain spaces and unsafe characters+escapeString :: String -> String -> Content i+escapeString key value =+ CElem (Elem key [] [ CString True value undefined ]) undefined++comment :: String -> Content i+comment s = CMisc (Comment (commentEscape s)) undefined++-- Replace occurences of "-->" with "==>" in a string so that the string+-- becomes safe for an XML comment+commentEscape :: String -> String+commentEscape [] = []+commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs+commentEscape (x:xs) = x : commentEscape xs++---------------------------------------------------------+-- Check whether the network read from file is valid+---------------------------------------------------------++networkValid :: [AssocN n] -> [AssocE e] -> XMLParser ()+networkValid nodeAssocs edgeAssocs+ | containsDuplicates nodeNrs =+ fail "Node numbers should be unique"+ | containsDuplicates edgeNrs =+ fail "Edge numbers should be unique"+ | otherwise =+ do{ mapM_ (checkEdge nodeNrs) edgeAssocs+ ; -- determine whether there are multiple edges between any two nodes+ ; let multipleEdges = duplicatesBy betweenSameNodes edges+ ; when (not (null multipleEdges)) $+ fail $ "There are multiple edges between the following node pairs: " +++ commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", "+ ++ show (getEdgeTo e) ++ ")"+ | e <- multipleEdges+ ]+ ; return ()+ }+ where+ nodeNrs = map (fst . deAssocN) nodeAssocs+ (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)++-- Check whether edges refer to existing node numbers and whether+-- there are no edges that start and end in the same pair (node, port)+checkEdge :: [NodeNr] -> AssocE e -> XMLParser ()+checkEdge nodeNrs (AssocE edgeNr edge)+ | (fromNr, fromPort) == (toNr, toPort) =+ fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"+ | fromNr `notElem` nodeNrs = nonExistingNode fromNr+ | toNr `notElem` nodeNrs = nonExistingNode toNr+ | otherwise = return ()+ where+ fromNr = getEdgeFrom edge+ fromPort = getPortFrom edge+ toNr = getEdgeTo edge+ toPort = getPortTo edge+ nonExistingNode nodeNr =+ fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "+ ++ show nodeNr++containsDuplicates :: Eq a => [a] -> Bool+containsDuplicates xs = length (nub xs) /= length xs++-- Partial equality on edges+betweenSameNodes :: Edge e -> Edge e -> Bool+betweenSameNodes e1 e2 =+ ( getEdgeFrom e1 == getEdgeFrom e2 && getEdgeTo e1 == getEdgeTo e2 + && getPortFrom e1 == getPortFrom e2 && getPortTo e1 == getPortTo e2 )+ ||+ ( getEdgeFrom e1 == getEdgeTo e2 && getEdgeTo e1 == getEdgeFrom e1+ && getPortFrom e1 == getPortTo e2 && getPortTo e1 == getPortFrom e2 )++-- Returns elements that appear more than once in a list+duplicates :: Eq a => [a] -> [a]+duplicates [] = []+duplicates (x:xs)+ | x `elem` xs = x : duplicates (filter (/= x) xs)+ | otherwise = duplicates xs++-- Returns elements that appear more than once in a list, using given Eq op+duplicatesBy :: (a->a->Bool) -> [a] -> [a]+duplicatesBy _ [] = []+duplicatesBy eq (x:xs)+ | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)+ | otherwise = duplicatesBy eq xs+
+ src/NetworkUI.hs view
@@ -0,0 +1,565 @@+{-# OPTIONS -cpp -fglasgow-exts #-} +module NetworkUI+ ( create+ , getConfig, Config+ ) where++import SafetyNet+import State+import StateUtil+import Network+import Document+import INRule+import Common+import CommonIO+import qualified PersistentDocument as PD+import qualified PDDefaults as PD+import InfoKind+import DisplayOptions+import Constants+import Text.XML.HaXml.XmlContent (XmlContent)+import Text.Parse as Parse+import Operations+import INReduction+import INChecksUI+import CommonUI++import Graphics.UI.WX hiding (Child, upKey, downKey, swap)+import Graphics.UI.WXCore+import Functional.UI++data Config = NFC+ { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height+ , nfcFileName :: Maybe String+ , nfcSelection :: Document.Selection+ }+ deriving (Read, Show)++getConfig :: State g n e -> IO Config+getConfig state =+ do{ theFrame <- getNetworkFrame state+ ; (x, y) <- safeGetPosition theFrame+ ; winSize <- get theFrame clientSize+ ; pDoc <- getDocument state+ ; maybeFileName <- PD.getFileName pDoc+ ; doc <- PD.getDocument pDoc+ ; return (NFC+ { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize)+ , nfcFileName = maybeFileName+ , nfcSelection = getSelection doc+ })+ }+++create :: (InfoKind n g, InfoKind e g, XmlContent g, Parse g, Show g) =>+ State g n e -> g -> n -> e -> GraphOps g n e -> IO ()+create state g n e ops =++{- Containment structure of widgets: ++ * theFrame :: Frame ()+ ** mainPan :: Panel ()+ *** sp :: SplitterWindow ()+ **** sp1 :: SplitterWindow ()+ ***** sp2 :: SplitterWindow ()+ ****** palettePan :: Panel ()+ ******* palPan :: Panel ()+ ******* addAgent :: Button ()+ ****** rulesTreePan :: Panel ()+ ******* tree :: TreeCtrl ()+ ******* buttonNewRule :: Button ()+ ******* buttonNewIRule :: Button ()+ ***** sp3 :: SplitterWindow ()+ ****** sp4 :: SplitterWindow ()+ ******* ruleLHSPan :: Panel ()+ ****** canvas+ ******* ruleRHSPan :: Panel ()+ ****** lhs2rhsB :: Button ()+ ****** canvas+ ****** netPan :: Panel ()+ ******* canvas+ ******* strategies :: RadioBox ()+ ******* steps :: RadioBox ()+ ******* reduceB :: Button ()+ ******* reduceStopB :: Button ()+ **** textlog :: TextCtrl ()+-} ++ do{ theFrame <- frame [ text := "Interaction Nets editor"+ , position := pt 200 20+ , clientSize := sz 300 240 ]+ ; setNetworkFrame theFrame state++ -- Panels and SplitterWindows+ ; mainPan <- panel theFrame []+ ; sp <- splitterWindow mainPan []+ ; sp1 <- splitterWindow sp []+ ; sp2 <- splitterWindow sp1 []+ ; sp3 <- splitterWindow sp1 []+ + -- create a panel and put the Visible Palette with buttons on it + ; palettePan <- panel sp2 [] + ; palPan <- panel palettePan [] + ; setPalettePanel palPan state++ ; rulesTreePan <- panel sp2 [] + ; sp4 <- splitterWindow sp3 []+#if !defined(__APPLE__)+ ; ruleLHSPan <- panel sp4 []+#endif + ; ruleRHSPan <- panel sp4 []++ ; netPan <- panel sp3 []+ -- Create page setup dialog and save in state+ ; pageSetupData <- pageSetupDialogDataCreate+ ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData+ ; objectDelete pageSetupData+ ; setPageSetupDialog initialPageSetupDialog state++ -- Drawing area for net+ ; let (width, height) = getCanvasSize (Network.empty g n e)+ ; ppi <- getScreenPPI+ ; canvas <- scrolledWindow netPan+ [ virtualSize := sz (logicalToScreenX ppi width)+ (logicalToScreenY ppi height)+ , scrollRate := sz 10 10+ , bgcolor := wxcolor paneBackgroundColor+ , fullRepaintOnResize := False+ ]+ ; State.setCanvas canvas state++ -- Dummy persistent document to pass around+ ; pDoc <- getDocument state++ -- Attach handlers to drawing area+ ; set canvas+ [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc Net+ , on mouse := \p -> safetyNet theFrame $+ do setActiveCanvas Net state+ mouseEvent p canvas theFrame state+ --; focusOn canvas+ , on keyboard := \k -> safetyNet theFrame $+ do setActiveCanvas Net state+ keyboardEvent theFrame state k+ --; focusOn canvas+ ]++ -- Drawing area for LHS+ ; let (width, height) = (100, 100) -- getCanvasSize (Network.empty g n e)+ ; ppi <- getScreenPPI+#if !defined(__APPLE__)+ ; canvasLHS <- scrolledWindow ruleLHSPan+#else+ ; canvasLHS <- scrolledWindow sp4+#endif+ [ virtualSize := sz (logicalToScreenX ppi width)+ (logicalToScreenY ppi height)+ , scrollRate := sz 10 10+ , bgcolor := wxcolor paneBackgroundColor+ , fullRepaintOnResize := False+ ]+ ; State.setLHSCanvas canvasLHS state++ -- Attach handlers to drawing area+ ; set canvasLHS+ [ on paint := \dc _ -> safetyNet theFrame + $ do rule <- getActiveRule state+ paintHandler state dc $ LHS rule + , on mouse := \p -> safetyNet theFrame $+ do setActiveCanvas (LHS "") state+ mouseEvent p canvasLHS theFrame state+ --; focusOn canvasLHS+ , on keyboard := \k -> safetyNet theFrame $+ do setActiveCanvas (LHS "") state+ keyboardEvent theFrame state k+ --; focusOn canvasLHS+ ]++ -- buttons to copy LHS to RHS+ ; lhs2rhsB <- button ruleRHSPan [ text := "==>"+ , tooltip := "Copy the LHS network to the RHS."+ , on command := safetyNet theFrame + $ lhs2rhsItem True state+ ]+ -- only copies the interface+ ; lhsInt2rhsB <- button ruleRHSPan [ text := "=->"+ , tooltip := "Copy the LHS interface to the RHS."+ , on command := safetyNet theFrame + $ lhs2rhsItem False state+ ]++ -- Drawing area for RHS+ ; let (width, height) = (100, 100) -- getCanvasSize (Network.empty g n e)+ ; ppi <- getScreenPPI+ ; canvasRHS <- scrolledWindow ruleRHSPan+ [ virtualSize := sz (logicalToScreenX ppi width)+ (logicalToScreenY ppi height)+ , scrollRate := sz 10 10+ , bgcolor := wxcolor paneBackgroundColor+ , fullRepaintOnResize := False+ ]+ ; State.setRHSCanvas canvasRHS state++ -- Attach handlers to drawing area+ ; set canvasRHS+ [ on paint := \dc _ -> safetyNet theFrame + $ do rule <- getActiveRule state+ paintHandler state dc $ RHS rule + , on mouse := \p -> safetyNet theFrame $+ do setActiveCanvas (RHS "") state+ mouseEvent p canvasRHS theFrame state+ --; focusOn canvasLHS+ , on keyboard := \k -> safetyNet theFrame $+ do setActiveCanvas (RHS "") state+ keyboardEvent theFrame state k+ --; focusOn canvasLHS+ ]++ -- to debug purposes+ ; textlog <- textCtrlRich sp [enabled := False, wrap := WrapNone]+ -- use text control as logger+ ; textCtrlMakeLogActiveTarget textlog++ -- File menu+ ; fileMenu <- menuPane [ text := "&File" ]+ ; menuItem fileMenu+ [ text := "New\tCtrl+N"+ , on command := safetyNet theFrame $ newItem state g n e+ ]+ ; menuItem fileMenu+ [ text := "Open...\tCtrl+O"+ , on command := safetyNet theFrame $ openItem theFrame state+ >> singleCheckOverIN iNCheck state+ ]+ ; saveItem <- menuItem fileMenu+ [ text := "Save\tCtrl+S"+ , on command := safetyNet theFrame $ checkValidINOnSave state $ PD.save pDoc+ ]+ ; menuItem fileMenu+ [ text := "Save as..."+ , on command := safetyNet theFrame $ checkValidINOnSave state $ PD.saveAs pDoc+ ]++ ; menuLine fileMenu++ ; menuItem fileMenu+ [ text := "Page setup..."+ , on command := safetyNet theFrame $+ do{ psd <- getPageSetupDialog state+ ; dialogShowModal psd+ ; return ()+ }+ ]++ ; menuItem fileMenu+ [ text := "Print..."+ , on command := safetyNet theFrame $+ let printFun _ printInfo _ dc _ =+ do { dcSetUserScale dc+ (fromIntegral (sizeW (printerPPI printInfo))+ / fromIntegral (sizeW (screenPPI printInfo)))+ (fromIntegral (sizeH (printerPPI printInfo))+ / fromIntegral (sizeH (screenPPI printInfo)))+ ; paintHandler state dc Net+ }+ pageFun _ _ _ = (1, 1)+ in+ do{ psd <- getPageSetupDialog state+ ; printDialog psd (toolName ++ " print") pageFun printFun+ }+ ]++ ; menuItem fileMenu+ [ text := "Print preview"+ , on command := safetyNet theFrame $+ let printFun _ _ _ dc _ = paintHandler state dc Net+ pageFun _ _ _ = (1, 1)+ in+ do{ psd <- getPageSetupDialog state+ ; printPreview psd (toolName ++ " preview") pageFun printFun+ }+ ]++ ; menuLine fileMenu++ ; menuItem fileMenu+ [ text := "E&xit"+ , on command := close theFrame+ ]++ -- Edit menu+ ; editMenu <- menuPane [ text := "&Edit" ]+ ; undoItem <- menuItem editMenu+ [ on command := safetyNet theFrame $ do PD.undo pDoc; repaintAll state ]+ ; redoItem <- menuItem editMenu+ [ on command := safetyNet theFrame $ do PD.redo pDoc; repaintAll state ]+{-+ ; menuLine editMenu+ ; menuItem editMenu+ [ text := "Edit global info..."+ , on command := safetyNet theFrame $ changeGlobalInfo theFrame state+ ]+-}++ -- View menu+ ; viewMenu <- menuPane [ text := "&View" ]+ ; (DP opts) <- getDisplayOptions state+ ; menuItem viewMenu+ [ text := "Node Label"+ , checkable := True+ , checked := NodeLabel `elem` opts+ , on command := safetyNet theFrame $ do+ { changeDisplayOptions (toggle NodeLabel) state+ ; repaintAll state } ]+{-+ ; menuItem viewMenu+ [ text := "Node Info"+ , checkable := True+ , checked := NodeInfo `elem` opts+ , on command := safetyNet theFrame $ do+ { changeDisplayOptions (toggle NodeInfo) state+ ; repaintAll state } ]+-}+ ; menuItem viewMenu+ [ text := "Edge Label"+ , checkable := True+ , checked := EdgeLabel `elem` opts+ , on command := safetyNet theFrame $ do+ { changeDisplayOptions (toggle EdgeLabel) state+ ; repaintAll state } ]+{-+ ; menuItem viewMenu+ [ text := "Edge Info"+ , checkable := True+ , checked := EdgeInfo `elem` opts+ , on command := safetyNet theFrame $ do+ { changeDisplayOptions (toggle EdgeInfo) state+ ; repaintAll state } ]+-}++ -- Operations menu+ ; opsMenu <- menuPane [ text := "&Operations" ]+ ; mapM_ (\ (name,_)->+ menuItem opsMenu+ [ text := name + , on command := safetyNet theFrame $ do+ { callPureGraphOp name ops state+ ; repaintAll state }+ ]+ ) (pureOps ops)+ ; when (not . null $ pureOps ops)+ $ menuLine opsMenu++ ; mapM_ (\ (name,_)->+ menuItem opsMenu+ [ text := name + , on command := safetyNet theFrame $ do+ { callIOGraphOp name ops state+ ; repaintAll state }+ ]+ ) (ioOps ops)+ ; when (not . null $ ioOps ops)+ $ menuLine opsMenu++ ; menuItem opsMenu+ [ text := "Functional term to IN system"+ , on command := safetyNet theFrame $ compileUI state g n e+ ]++ -- Palette menu+ ; palMenu <- menuPane [ text := "&Symbols" ]+ ; menuItem palMenu + [ text := "Save palette as ..."+ , on command := safetyNet theFrame $ savePalette theFrame state+ ]+ ; menuItem palMenu+ [ text := "Change shape palette..."+ , on command := safetyNet theFrame $ + do yes <- confirmDialog theFrame "Dangerous operation!!" "Changing the palette can lead to severe errors.\nUnless you know what you are doing, don't proceed.\nDo you really want to proceed ?" False+ when yes $ openPalette theFrame state+ ]++ -- Checks menu+ ; chksMenu <- menuPane [text := "&Checks"]+ ; mapM_ (\ chk@(name, desc,_,_,_) ->+ menuItem chksMenu [ text := name+ , on command := safeAndClear theFrame textlog $ singleCheckOverIN chk state+ ]+ ) checksList+ ; menuLine chksMenu+ ; menuItem chksMenu [ text := "Multiple checks at once"+ , on command := safeAndClear theFrame textlog $ multipleChecksOverIN_UI theFrame state+ ]+ ; menuItem chksMenu [ text := "Checks over multiple files"+ , on command := safeAndClear theFrame textlog $ multipleChecksOverINs_UI state+ ]++ -- Help menu+ ; helpMenu <- menuPane [ text := "&Help" ]+ ; menuItem helpMenu + [ text := "How to use?"+ , on command := createHelpWindow + ]+ ; menuItem helpMenu + [ text := "About"+ , on command := createAboutWindow theFrame+ ]++ ; PD.initialise pDoc (PD.PD+ { PD.document = Document.empty g n e+ , PD.history = []+ , PD.future = []+ , PD.limit = Nothing+ , PD.fileName = Nothing+ , PD.dirty = False+ , PD.saveToDisk = saveToDisk theFrame+ , PD.updateUndo = PD.defaultUpdateUndo undoItem+ , PD.updateRedo = PD.defaultUpdateRedo redoItem+ , PD.updateSave = PD.defaultUpdateSave saveItem+ , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame toolName+ , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame toolName+ , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions+ })++ ; setInterfacePalette n state++ ; initializeRules state g n e+ -- Rules Panel+ ; tree <- treeCtrl rulesTreePan [style :~ (wxTR_EDIT_LABELS .+.)]+ ; setTree tree state+ ; top <- treeCtrlAddRoot tree "Rules" noImage noImage objectNull+ -- ; treeCtrlSetItemClientData tree top (return ()) ""+ ; addRules2Tree tree top state+ ; treeCtrlExpand tree top+ ; set tree [ on treeEvent := onTreeEvent tree state g n e]++ ; buttonNewRule <- button rulesTreePan + [ text := "Add new rule" + , on command := safetyNet theFrame $ addNewRuleItem True state $ initial g n e+ ]+ ; buttonNewIRule <- button rulesTreePan + [ text := "Rule creation wizard" + , on command := safetyNet theFrame $ createRuleItem theFrame state g n e+ ]+++ ; addAgent <- button palettePan [ text := "Create new symbol"+ , on command := createNewAgentItem state+ ]++ ; set palettePan [ layout := column 5 [ widget addAgent+ , hfloatCentre $ widget palPan ] ] +++ -- reduction+ ; reduceB <- button netPan + [ text := "Reduce" + , enabled := True + ]+ ; setReduceButton reduceB state++ ; reduceStopB <- button netPan + [ text := "Stop" + , enabled := False+ ]+ ; let (stratsS, _) = unzip strategiesList++ ; strategies <- radioBox netPan Vertical stratsS + [ text := "Strategy"+ , selection := 1 ] ++ ; steps <- radioBox netPan Vertical ["one", "many"] + [ text := "Steps"+ , selection := 0 ] ++ ; set reduceB [on command := do+ set reduceB [enabled := False]+ set reduceStopB [enabled := True]+ set strategies [enabled := False]+ set steps [enabled := False]+ setContinueReduction True state+ s <- get steps selection+ i <- get strategies selection+ globalReduce (stratsS !! i) (s==1) state+ set reduceStopB [enabled := False]+ set strategies [enabled := True]+ set steps [enabled := (stratsS !! i /= "Manual selection")]+ set reduceB [enabled := True]+ ]+ + ; set reduceStopB [ on command := do stopReduction state+ set reduceStopB [enabled := False]+ set reduceB [enabled := True]+ ]++ ; set strategies [ on select := + do i <- get strategies selection+ if stratsS !! i == "Manual selection"+ then set steps [ enabled := False+ , selection := 0+ ]+ else do set steps [ enabled := True]+ set reduceB [ enabled := True]++ ] +++ -- Layout the main window+ ; set theFrame+ [ menuBar := [ fileMenu, editMenu, viewMenu, opsMenu, palMenu, chksMenu, helpMenu ]+ , layout := container mainPan $ margin 5 $ fill $+ hsplit sp 5 500 ( -- to remove. just for debug + vsplit sp1 5 200 + (hsplit sp2 5 200 + (widget palettePan) + (container rulesTreePan $ + column 5 [ fill $ widget tree+ , hfloatCentre $ widget buttonNewRule+ , hfloatCentre $ widget buttonNewIRule++ ]+ ) + )+ (hsplit sp3 5 250+ (vsplit sp4 5 300+ ( +#if !defined(__APPLE__)+ container ruleLHSPan $ boxed "LHS" $ +#endif + fill $ widget canvasLHS)+ (container ruleRHSPan $ row 5 [ vstretch $ valignCenter $ column 5 [ widget lhs2rhsB+ , widget lhsInt2rhsB ]+ , +#if !defined(__APPLE__)+ boxed "RHS" $+#endif + fill $ widget canvasRHS + ] ) )+ (container netPan $ + column 5 [ fill $ widget canvas+ , +#if !defined(__APPLE__)+ boxed "Reduction" $+#endif+ hfloatLeft $ row 5 [ widget strategies+ , widget steps+ , column 5 [ widget reduceB+ , widget reduceStopB]+ ]+ ]+ ) + ) + )(widget textlog) -- to remove. just for debug +++ , clientSize := sz 900 600+ , statusBar := []+ , on closing := safetyNet theFrame $ checkValidINOnSave state $ exit state+ ]++ -- ; set theFrame+ -- [ position := pt 200 20+ -- , clientSize := sz 300 240+ -- ]+ }+
+ src/NetworkView.hs view
@@ -0,0 +1,418 @@+module NetworkView+ ( drawCanvas+ , clickedNode+ , clickedNodePort+ , clickedEdge+ , clickedVia+ , edgeContains+ ) where++import Constants+import CommonIO+import Network+import Document+import Colors+import Common+import Palette+import Ports+import Math+import Graphics.UI.WX as WX hiding (Vector, Selection)+import Graphics.UI.WXCore hiding (Document, screenPPI, Colour, Palette)+import Graphics.UI.WXCore.Draw+import Data.Maybe+import Shape+import DisplayOptions+import InfoKind++import Prelude hiding (catch)+import Control.Exception+import qualified Data.IntMap as IntMap+import Data.List++drawCanvas :: (InfoKind n g, InfoKind e g) =>+ Network g n e -> Palette n -> Selection -> [NodeNr] -- interface nodes mapped+ -> DC () -> DisplayOptions -> IO ()+drawCanvas net palette selec p dc opt =+ do{++ -- Scale if the DC we are drawing to has a different PPI from the screen+ -- Printing, nudge, nudge+ ; dcPPI <- dcGetPPI dc+ ; screenPPI <- getScreenPPI+ ; when (dcPPI /= screenPPI) $+ dcSetUserScale dc+ (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))+ (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))++ -- Set font+ ; set dc [ fontFamily := FontDefault, fontSize := 10 ]++ ; catch (reallyDrawCanvas net palette selec p screenPPI dc opt)+ (\e -> logicalText dcPPI dc (DoublePoint 50 50)+ ("Exception while drawing: "++show e)+ (Justify LeftJ TopJ) [] )+ }++reallyDrawCanvas :: (InfoKind n g, InfoKind e g) =>+ Network g n e -> Palette n -> Selection -> [NodeNr]+ -> Size -> DC () -> DisplayOptions -> IO ()+reallyDrawCanvas network palette theSelection mapp ppi dc opt =+ do{+ -- draw edges, highlight the selected ones (if any)+ ; mapM_ (\edge -> drawEdge edge []) (getEdgeAssocs network)+ ; case theSelection of+ EdgeSelection _ edgeNr -> do+ drawEdge (edgeNr, getEdge edgeNr network) kSELECTED_OPTIONS+ ViaSelection _ edgeNr viaNr -> do+ drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS+ MultipleSelection _ _ _ viaNrs -> do+ mapM_ (\ (e,v)-> drawVia (getEdge e network) v kSELECTED_OPTIONS)+ viaNrs+ _ -> return ()++ -- draw nodes, highlight the selected ones (if any)+ ; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network)+ ; case theSelection of+ NodeSelection _ nodeNr mPort ->+ do drawNode nodeNr (kSELECTED_OPTIONS+ ++ [ penColor := wxcolor activeSelectionColor ])+ case mPort of+ Nothing -> return ()+ Just str -> drawPort ppi dc+ (getPosition $ getNode nodeNr network)+ [brushKind := BrushSolid+ , brushColor := kPortSelectedColor]+ $ snd $ takeJust "inexistent port" $ getPort palette network (nodeNr, str)+ MultipleSelection _ _ nodeNrs _ ->+ mapM_ (\n-> drawNode n (kSELECTED_OPTIONS+ ++ [ penColor := wxcolor activeSelectionColor ]))+ nodeNrs+ _ -> return ()++ -- multiple selection drag area rectangle+ ; case theSelection of+ MultipleSelection _ (Just (p,q)) _ _ ->+ logicalRect ppi dc (doublePointX p) (doublePointY p)+ (doublePointX q - doublePointX p)+ (doublePointY q - doublePointY p)+ [ penColor := wxcolor lightGrey+ , brushKind := BrushTransparent]+ _ -> return ()++ -- canvas size rectangle+ -- ; let (width, height) = Network.getCanvasSize (getNetwork doc)+ -- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent]+ }+ where+ drawNode :: Int -> [Prop (DC ())] -> IO ()+ drawNode nodeNr options =+ do{+ -- draw node+ ; logicalDraw ppi dc center shape options+ -- ; logicalCircle ppi dc center kNODE_RADIUS options+ ; drawPorts ppi dc center ports options++ -- draw label+ ; when (NodeLabel `elem` dpShowInfo opt) $+ drawLabel (offset above) False (getName node) center+ (justif above) [ textColor := wxcolor kNodeLabelColour ] + -- draw info+ ; when (NodeInfo `elem` dpShowInfo opt) $+ drawLabel (offset (not above)) False (show (getInfo node))+ center (justif (not above))+ [ textColor := wxcolor kNodeInfoColour ]+ + -- draw mapping numbering when needed+ ; maybe ( return () )+ showInterfaceMap+ $ findIndex (nodeNr ==) mapp++ }+ where+ node = getNode nodeNr network+ above = getNameAbove node+ center = getPosition node+ symbol = takeJust "No symbol definition"+ $ getSymbol (getShape node) palette+ shape = fst3 symbol+ ports = snd3 symbol++ offset b = (if b then negate else id) kNODE_RADIUS+ justif b = Justify CentreJ (if b then BottomJ else TopJ)+ + showInterfaceMap n = + drawLabel 0.15 True (show $ succ n) center+ (justif above) [ textColor := wxcolor kNodeMapColour ]++ drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify+ -> [Prop (DC ())] -> IO ()+ drawLabel voffset boxed text (DoublePoint x y) justify opts =+ do{ -- draw background+ when boxed $ do+ { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text+ ; let horizontalMargin = 0.2 -- centimeters+ verticalMargin = 0.01 -- centimeters+ topleftY = y+voffset - case justify of+ Justify _ TopJ -> 0+ Justify _ MiddleJ -> textHeight/2+ Justify _ BottomJ -> textHeight+ + ; logicalRect ppi dc+ (x - textWidth/2 - horizontalMargin) (topleftY)+ (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)+ (solidFill labelBackgroundColor)+ }+ -- draw text+ ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts+ }++ isPrincipalPort' (nodeNr, port) =+ isPrincipalPort palette network nodeNr port && not (isInterfacePort port)+ isPrincipalPort' _ = False++ drawEdge :: InfoKind e g => (EdgeNr, Edge e) -> [Prop (DC ())] -> IO ()+ drawEdge (edgeNr, edge) options =+ do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options+ -- arrow on the end+ -- ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice)+ + -- arrow(s) on principal ports+ ; when hasPrincipalPorts + $ do when (isPrincipalPort' fromPort)+ $ logicalLine ppi dc [tw1, pw1, tw2] options + when (isPrincipalPort' toPort) + $ logicalLine ppi dc [tw3, pw2, tw4] options+ + -- draw label+ ; when (EdgeLabel `elem` dpShowInfo opt) $+ drawLabel 0 False (int2name edgeNr) + (translate (DoublePoint 0.2 0.1 )$ middle via)+ (Justify LeftJ TopJ)+ [ textColor := wxcolor kEdgeLabelColour ] ++ -- draw info+ ; when (EdgeInfo `elem` dpShowInfo opt) $+ -- logicalTextRotated ppi dc (middle via) (show info) 45+ -- [ textColor := wxcolor kEdgeInfoColour ]+ drawLabel 0 False (show (getEdgeInfo edge)) (middle via)+ (Justify CentreJ BottomJ)+ [ textColor := wxcolor kEdgeInfoColour ]+ }+ where+ fromNode = getNode (getEdgeFrom edge) network+ toNode = getNode (getEdgeTo edge) network++ fromPort = getFullPortFrom edge+ toPort = getFullPortTo edge+ + radius = kPortRadius+ fromNodePoint = getPosition fromNode+ toNodePoint = getPosition toNode++ fromPortPosition = snd . takeJust "Inexistent port" $ getPort palette network fromPort+ toPortPosition = snd . takeJust "Inexistent port" $ getPort palette network toPort++ fromPoint = translate fromNodePoint fromPortPosition+ toPoint = translate toNodePoint toPortPosition+ via = getEdgeVia edge++ fstEdgeVector = (head (via++[toPoint]))+ `subtractDoublePointVector` fromPoint+ fstTotalLen = vectorLength fstEdgeVector+ fstAngle = vectorAngle fstEdgeVector++ penultimatePt = head (reverse (fromPoint:via))+ endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt+ endTotalLen = vectorLength endEdgeVector+ endAngle = vectorAngle endEdgeVector++ middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2)+ ((doublePointY pt1 + doublePointY pt2)/2)+ middle [p] = p+ middle ps = middle (tail (reverse ps))++ pt1 = translatePolar fstAngle radius fromPoint+ pt2 = translatePolar endAngle (endTotalLen - radius) penultimatePt++ tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2+ tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2++ pw1 = translatePolar fstAngle (radius + kARROW_SIZE) fromPoint+ pw2 = translatePolar endAngle (endTotalLen - radius - kARROW_SIZE) penultimatePt++ tw1 = translatePolar (fstAngle + pi + pi / 6) kARROW_SIZE pw1+ tw2 = translatePolar (fstAngle + pi - pi / 6) kARROW_SIZE pw1++ tw3 = translatePolar (endAngle + pi / 6) kARROW_SIZE pw2+ tw4 = translatePolar (endAngle - pi / 6) kARROW_SIZE pw2++ drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO ()+ drawVia e n options =+ let pt = (getEdgeVia e)!!n in+ do logicalCircle ppi dc pt kEDGE_CLICK_RANGE+ (options ++ solidFill violet)++solidFill :: Colour -> [Prop (DC ())]+solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ]++-- | Finds which node of the network is clicked by the mouse, if any+clickedNode :: DoublePoint -> Document g n e -> ActiveCanvas -> Maybe Int+clickedNode clickedPoint doc canvas =+ let network = selectNetwork doc canvas + nodeAssocs = case getSelection doc of+ NodeSelection canv nodeNr _ + | canv == canvas -> [(nodeNr, getNode nodeNr network)]+ | otherwise -> []+ _ -> []+ ++ reverse (getNodeAssocs network)+ in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of+ [] -> Nothing+ ((i, _):_) -> Just i++-- | Finds which node and port of the network is clicked by the mouse, if any+clickedNodePort :: DoublePoint -> Document g n e -> ActiveCanvas+ -> Maybe (NodeNr, Maybe PortName)+clickedNodePort clickedPoint doc canvas =+ let network = selectNetwork doc canvas + nodeAssocs = case getSelection doc of+ NodeSelection canv nodeNr _ + | canv == canvas -> [(nodeNr, getNode nodeNr network)]+ | otherwise -> []+ _ -> []+ ++ reverse (getNodeAssocs network)+ in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of+ [] -> Nothing+ ((i, n):_) -> case getPorts (getPalette doc) network i of+ Nothing -> Nothing -- no symbol definition. Shouldn't occur+ Just ps -> + case filter (\p -> portContains n p clickedPoint) ps of+ [] -> Just (i, Nothing) -- if the mouse is over a node + -- with ports but not over any+ -- of its ports the node is selected+ (port:_) -> Just (i, Just $ fst port)++nodeContains :: Node n -> DoublePoint -> Bool+nodeContains node clickedPoint =+ distancePointPoint (getPosition node) clickedPoint+ < kNODE_RADIUS++portContains :: Node n -> Port -> DoublePoint -> Bool+portContains node (_, portP) clickedPoint = + distancePointPoint portCenter clickedPoint+ < kPortSelectionRadius+ where portCenter = translate (getPosition node) portP++-- | Finds which edge of the network is clicked by the mouse, if any+clickedEdge :: DoublePoint -> Network g n e -> Maybe Int+clickedEdge clickedPoint network =+ let assocs = getEdgeAssocs network+ in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of+ [] -> Nothing+ ((i, _):_) -> Just i++edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int+edgeContains edge clickedPoint network =+ let p0 = getNodePosition network (getEdgeFrom edge)+ p1 = getNodePosition network (getEdgeTo edge)+ via= getEdgeVia edge+ p = clickedPoint+ numberedDistancesToSegments = zip [0..] $+ zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p)+ (p0:via) (via++[p1])+ in case [ nr | (nr,dist) <- numberedDistancesToSegments+ , dist < kEDGE_CLICK_RANGE ] of+ [] -> Nothing+ nrs -> Just (head nrs)++-- | Finds which 'via' control point is clicked by the mouse, if any+clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int)+clickedVia clickedPoint network =+ let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v))+ [0..] (getEdgeVia e))+ (IntMap.toList (networkEdges network))+ in case filter (\ (_,v)-> distancePointPoint v clickedPoint+ < kEDGE_CLICK_RANGE) allVia of+ [] -> Nothing+ ((kn,_):_) -> Just kn++-- Drawing operations in logical coordinates++logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO ()+logicalCircle ppi dc center radius options =+ WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options++logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO ()+logicalRect ppi dc x y width height options =+ drawRect dc+ (rect+ (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y))+ (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height)))+ options++data Justify = Justify Horizontal Vertical deriving Eq+data Horizontal = LeftJ | CentreJ | RightJ deriving Eq+data Vertical = TopJ | MiddleJ | BottomJ deriving Eq++-- can deal with multi-line text+logicalText :: Size -> DC () -> DoublePoint -> String -> Justify+ -> [Prop (DC ())] -> IO ()+logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options =+ do{ (width,height) <- logicalGetTextExtent ppi dc txt+ ; eachLine width (startPos height) (lines txt)+ }+ where+ startPos height = case vert of TopJ -> (x, y)+ MiddleJ -> (x, y-height/2)+ BottomJ -> (x, y-height)+ eachLine _ _ [] = return ()+ eachLine maxwidth (x,y) (txt:txts) =+ do{ (w,h) <- logicalGetTextExtent ppi dc txt+ ; let thisX = case horiz of LeftJ -> x-maxwidth/2+ CentreJ -> x-w/2+ RightJ -> x+(maxwidth/2)-w+ ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y))+ options+ ; eachLine maxwidth (x,y+h) txts+ }++-- currently assumes only single line of text+logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double+ -> [Prop (DC ())] -> IO ()+logicalTextRotated ppi dc pos txt angle options =+ draw dc txt (logicalToScreenPoint ppi pos) options+ where+ draw = if angle<1 && angle>(-1) then drawText+ else (\a b c e -> rotatedText a b c angle e)+++{-+logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO ()+logicalLine ppi dc fromPoint toPoint options =+ line dc (logicalToScreenPoint ppi fromPoint)+ (logicalToScreenPoint ppi toPoint) options++logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()+logicalLineSegments _ _ [p] options = return ()+logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =+ do{ line dc (logicalToScreenPoint ppi fromPoint)+ (logicalToScreenPoint ppi toPoint) options+ ; logicalLineSegments ppi dc (toPoint:ps) options+ }+-}++logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()+logicalPoly ppi dc points options =+ polygon dc (map (logicalToScreenPoint ppi) points) options++logicalLine :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()+logicalLine ppi dc points options =+ polyline dc (map (logicalToScreenPoint ppi) points) options++logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double)+logicalGetTextExtent ppi dc txt =+ do{ textSizes <- mapM (getTextExtent dc) (lines txt)+ ; return+ ( screenToLogicalX ppi (maximum (map sizeW textSizes))+ , screenToLogicalY ppi (sum (map sizeH textSizes))+ )+ }
+ src/Operations.hs view
@@ -0,0 +1,68 @@+module Operations where++import Network+import State+import Document+import qualified PersistentDocument as PD++import Data.IntMap++-- | @GraphOps@ is a data structure holding a bunch of named operations+-- on the document. The operations are classified into pure and+-- IO variants. A pure operation takes a document and returns a new+-- document and displayed immediately. An IO operation is simply+-- executed taking the document as argument and the state.+data GraphOps g n e = GraphOps+ { pureOps :: [ (String, PureOp g n e) ]+ , ioOps :: [ (String, IOOp g n e) ]+ }+type PureOp g n e = -- (InfoKind n g, InfoKind e g)+ Document g n e -> Document g n e+type IOOp g n e = -- (InfoKind n g, InfoKind e g) =>+ Document g n e -> State g n e -> IO ()++type PureNetworkOp g n e = -- (InfoKind n g, InfoKind e g)+ (g, IntMap (Node n), IntMap (Edge e))+ -> (g, IntMap (Node n), IntMap (Edge e))+type IONetworkOp g n e = -- (InfoKind n g, InfoKind e g) =>+ (g, IntMap (Node n), IntMap (Edge e))+ -> State g n e+ -> IO ()++callPureGraphOp :: String -> GraphOps g n e -> State g n e -> IO ()+callPureGraphOp opName allGraphOps state = + do{ pDoc <- getDocument state+ ; let operation = maybe id id (Prelude.lookup opName (pureOps allGraphOps))+ ; PD.updateDocument opName operation pDoc+ }++callIOGraphOp :: String -> GraphOps g n e -> State g n e -> IO ()+callIOGraphOp opName allGraphOps state =+ do{ pDoc <- getDocument state+ ; doc <- PD.getDocument pDoc+ ; maybe (return ()) (\op-> op doc state)+ (Prelude.lookup opName (ioOps allGraphOps))+ }+++globalizePure :: PureNetworkOp g n e -> PureOp g n e+globalizePure netOperation = updateNetwork aux+ where aux network = + let g = getGlobalInfo network+ n = networkNodes network+ e = networkEdges network+ (g',n',e') = netOperation (g,n,e)+ in setNodeAssocs (assocs n')+ . setEdgeAssocs (assocs e')+ . setGlobalInfo g'+ $ network++globalizeIO :: IONetworkOp g n e -> IOOp g n e+globalizeIO netOperation doc state = + do{ let network = getNetwork doc+ g = getGlobalInfo network+ n = networkNodes network+ e = networkEdges network+ ; netOperation (g, n, e) state+ }+
+ src/PDDefaults.hs view
@@ -0,0 +1,91 @@+{-| Module : PDDefaults+ Author : Arjan van IJzendoorn+ License : do whatever you like with this++ Maintainer : afie@cs.uu.nl++ Some defaults for the field of the persistent document+ record. For example, the default undo update function+ changes the text of a menu item to reflect what will be+ undo and disables it if there is nothing to be undone.+ You might want more than the defaults if you have a+ more advanced GUI. Let's say you also have a button+ in a toolbar to undo, then you might want to gray out+ that button, too, if there is nothing to be undone.+-}++module PDDefaults where++import Graphics.UI.WX+import Graphics.UI.WXCore(wxID_CANCEL)++type Extensions = [(String, [String])]++-- Update the menu item "Undo" to show which+-- action will be undone. If there is nothing+-- to undo the corresponding menu item is disabled+defaultUpdateUndo :: MenuItem () -> Bool -> String -> IO ()+defaultUpdateUndo undoItem enable message = + set undoItem+ [ text := "Undo " ++ message ++ "\tCtrl+Z"+ , enabled := enable+ ]+ +defaultUpdateRedo :: MenuItem () -> Bool -> String -> IO ()+defaultUpdateRedo redoItem enable message = + set redoItem+ [ text := "Redo " ++ message ++ "\tCtrl+Y"+ , enabled := enable+ ]++-- Enable the save item only if the document is dirty+defaultUpdateSave :: MenuItem () -> Bool -> IO ()+defaultUpdateSave saveItem enable = + set saveItem [ enabled := enable ]++-- Update the title bar: program name - document name followed by "(modified)" if+-- the document is dirty+defaultUpdateTitlebar :: Frame () -> String -> Maybe String -> Bool -> IO ()+defaultUpdateTitlebar theFrame programName theFileName modified = + let newTitle = programName+ ++ " - " + ++ (case theFileName of Nothing -> "untitled"; Just name -> name) + ++ (if modified then " (modified)" else "")+ in set theFrame [ text := newTitle ]++-- | defaultSaveChangesDialog shows a dialog with three buttons with corresponding+-- return values: Don't Save -> Just False, Save -> Just True+-- Cancel -> Nothing+defaultSaveChangesDialog :: Frame () -> String -> IO (Maybe Bool)+defaultSaveChangesDialog parentWindow theProgramName = + do{ d <- dialog parentWindow [text := theProgramName]+ ; p <- panel d []+ ; msg <- staticText p [text := "Do you want to save the changes?"]+ ; dontsaveB <- button p [text := "Don't Save"]+ ; saveB <- button p [text := "Save"] + ; cancelB <- button p [text := "Cancel", identity := wxID_CANCEL ] + ; set d [layout := margin 10 $ container p $ + column 10 [ hfill $ widget msg+ , row 50 [ floatBottomLeft $ widget dontsaveB + , floatBottomRight $ row 5 [ widget saveB, widget cancelB]+ ]+ ]+ ] + ; set p [ defaultButton := saveB ] + ; showModal d $ \stop -> + do set dontsaveB [on command := stop (Just False) ]+ set saveB [on command := stop (Just True) ]+ set cancelB [on command := stop Nothing ]+ }++defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String)+defaultSaveAsDialog theFrame extensions theFileName =+ fileSaveDialog+ theFrame+ False -- remember current directory+ True -- overwrite prompt+ "Save file"+ extensions+ "" -- directory+ (case theFileName of Nothing -> ""; Just name -> name) -- initial file name+
+ src/Palette.hs view
@@ -0,0 +1,42 @@+module Palette where++import Data.List (nub, (\\), deleteBy)+import Shape+import Math+import Text.Parse as Parse+import Ports+++type ShapeName = String+data Palette a = Palette [ (ShapeName, (Shape, Ports, Maybe a)) ]+ deriving (Eq, Show, Read)++shapes :: Palette a -> [ (ShapeName,(Shape, Ports, Maybe a)) ]+shapes (Palette p) = p++join :: Eq a => Palette a -> Palette a -> Palette a+join (Palette p) (Palette q) = Palette (nub (p++q))++delete :: Eq a => Palette a -> Palette a -> Palette a+delete (Palette p) (Palette q) = Palette (p\\q)++deleteShape :: String -> Palette a -> Palette a+deleteShape name (Palette p) = Palette $ deleteBy equal (name, undefined) p+ where equal (name1,_) (name2,_) = name1 == name2++-- cannot be completely empty, always one default shape+empty :: Palette a+empty = Palette [("circle", (Shape.circle, [], Nothing))]++shapesNames :: Palette a -> [ShapeName]+shapesNames = map fst . shapes++instance Functor Palette where+ fmap _ (Palette p) = Palette (map (\ (n,(s,a,_))-> (n,(s,a,Nothing))) p)++instance Parse a => Parse (Palette a) where+ parse = do{ isWord "Palette"; fmap Palette $ parse }++getSymbol :: ShapeName -> Palette a -> Maybe (Shape, Ports, Maybe a)+getSymbol shapeName = lookup shapeName . shapes+
+ src/PersistentDocument.hs view
@@ -0,0 +1,338 @@+{-| Module : PersistentDocument+ Author : Arjan van IJzendoorn+ License : do whatever you like with this++ Maintainer : afie@cs.uu.nl++ The persistent document abstraction takes care of dealing+ with a document you want to open from and save to disk and+ that supports undo. This functionality can be used by editors+ of arbitrary documents and saves you a lot of quite subtle+ coding. You only need to initialise a record with things like+ your document, the file name and call-back functions. After+ this, the framework takes care of the hard work. The framework+ is highly parametrisable but there are defaults for many+ parameters.++ The features in detail:+ - unlimited undo & redo buffers (or limited, if you choose to)+ - undo and redo items show what will be undone / redone+ (e.g. "Undo delete node")+ - undo and redo items are disabled if there is nothing to undo or redo+ - maintains a dirty bit that tells you whether the document has+ changed with respect to the version on disk+ - the save menu item can be disabled if the document is not dirty+ - the title bar can be updated to show the program name, the file name+ and whether the document is dirty (shown as "modified")+ - when trying to close the document, the user is asked whether he/she+ wants to save the changes (if needed)+ - handles interaction between saving a document and the dirty bits+ of the document and of the documents in the history and future+ - properly handles Cancel or failure at any stage, e.g. the user+ closes a dirty document with no file name, "Do you want to save+ the changes" dialog is shown, user selects "Save", a Save as+ dialog is opened, user selects a location that happens to be+ read-only, saving fails and the closing of the document is+ cancelled.+-}++module PersistentDocument+ ( PersistentDocument, PDRecord(..)++ , PersistentDocument.dummy+ , initialise+ , resetDocument++ , setDocument, updateDocument+ , superficialSetDocument, superficialUpdateDocument++ , getDocument+ , getFileName, setFileName+ , setDirty++ , undo, redo+ , save, saveAs, isClosingOkay+ ) where++import Data.IORef(IORef, newIORef, writeIORef, readIORef)+import Monad(when)++-- | A persistent document is a mutable variable. This way functions+-- operating on a document do not have to return the new value but+-- simply update it.+type PersistentDocument a = IORef (PDRecord a)++-- | The persistent document record maintains all information needed+-- for undo, redo and file management+data PDRecord a = PD+ { document :: a++ -- UNDO & REDO+ , history :: [(String, Bool, a)]+ -- ^ A history item contains a message (what will be undone),+ -- the dirty bit and a copy of the document+ , future :: [(String, Bool, a)]+ -- ^ See history+ , limit :: Maybe Int+ -- ^ Maximum number of items of undo history. Or no limit+ -- in the case of Nothing++ -- FILE MANAGEMENT+ , fileName :: Maybe String+ -- ^ Nothing means no file name yet (untitled)+ , dirty :: Bool+ -- ^ Has the document changed since saving?++ -- CALL-BACK FUNCTIONS+ , updateUndo :: Bool -> String -> IO ()+ -- ^ This callback is called when the undo status changes. First parameter+ -- means enable (True) or disable (False). Second parameter is the message+ -- of the first item in the history+ , updateRedo :: Bool -> String -> IO ()+ -- ^ See updateUndo+ , updateSave :: Bool -> IO ()+ -- ^ This call-back is called when the save status changes. The boolean+ -- indicates whether save is enabled (dirty document) or disabled (not dirty)+ , updateTitleBar :: Maybe String -> Bool -> IO ()+ -- ^ This call-back is called when the title bar information changes:+ -- file name and modified or not.+ , saveToDisk :: String -> a -> IO Bool+ -- ^ This callback should actually save the document to disk. It should+ -- return False if saving fails (no permission, disk full...)+ , saveChangesDialog :: IO (Maybe Bool)+ -- ^ This call-back is called when the user should be prompted whether+ -- he\/she wants to save the changes or not. Results:+ -- Don\'t Save -> Just False, Save -> Just True, Cancel -> Nothing+ , saveAsDialog :: Maybe String -> IO (Maybe String)+ -- ^ This call-back is called when the user should specify a+ -- location and a name for the file. The parameter is the current+ -- file name of the document+ }++-- | A dummy persistent document is needed because you need something to pass+-- to the command handlers of menu items BEFORE you can initialse the+-- persistent document with those menu items+dummy :: IO (PersistentDocument a)+dummy = newIORef (error $ "PersistentDocument.empty: call initialise before using "+ ++ "the persistent document")++-- | Initialise the persistent document with menu items (undo, redo, save),+-- information needed for open & save dialogs, for saving and for updating the+-- title bar+initialise :: PersistentDocument a -> PDRecord a -> IO ()+initialise pDocRef pDoc =+ do{ writeIORef pDocRef pDoc+ ; updateGUI pDocRef+ }++-- | Clear the document and start with a given document with given file name+-- This function is typically called when you open a new document from disk+-- or start a fresh document that should replace the current document+resetDocument :: Maybe String -> a -> PersistentDocument a -> IO ()+resetDocument theFileName doc pDocRef =+ do{ updateIORef pDocRef (\pDoc -> pDoc+ { document = doc+ , history = []+ , future = []+ , fileName = theFileName+ , dirty = False+ })+ ; updateGUI pDocRef+ }++-- | Get the actual document stored within the persistent document+getDocument :: PersistentDocument a -> IO a+getDocument pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; return (document pDoc)+ }++-- | Get the file name stored within the persistent document+getFileName :: PersistentDocument a -> IO (Maybe String)+getFileName pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; return (fileName pDoc)+ }++-- | Get the file name stored within the persistent document+setFileName :: PersistentDocument a -> Maybe String -> IO ()+setFileName pDocRef maybeName =+ do{ pDoc <- readIORef pDocRef+ ; writeIORef pDocRef (pDoc { fileName = maybeName })+ ; updateGUI pDocRef+ }++setDirty :: PersistentDocument a -> Bool -> IO ()+setDirty pDocRef newDirtyBit =+ do{ pDoc <- readIORef pDocRef+ ; writeIORef pDocRef (pDoc { dirty = newDirtyBit })+ ; updateGUI pDocRef+ }++-- | Replace the document inside the persistent document. The current+-- document is remembered in the history list along with the given+-- message. The future list is cleared.+setDocument :: String -> a -> PersistentDocument a -> IO ()+setDocument message newDoc pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; let applyLimit = case limit pDoc of+ Nothing -> id+ Just nr -> take nr+ newPDoc =+ pDoc+ { document = newDoc+ , history = applyLimit $ (message,dirty pDoc,document pDoc):history pDoc+ , future = []+ , dirty = True+ }+ ; writeIORef pDocRef newPDoc+ ; updateGUI pDocRef+ }+++-- | Get document, apply function, set document+updateDocument :: String -> (a -> a) -> PersistentDocument a -> IO ()+updateDocument message fun pDocRef =+ do{ doc <- getDocument pDocRef+ ; setDocument message (fun doc) pDocRef+ }++-- | Replace the document without remembering the old document in+-- the history. Superficial updates are useful if something as+-- volatile as a selection is part of your document. If the selection+-- changes you don't want to be able to undo it or to mark+-- the document as dirty+superficialSetDocument :: a -> PersistentDocument a -> IO ()+superficialSetDocument newDoc pDocRef =+ updateIORef pDocRef (\pDoc -> pDoc { document = newDoc })++-- | Get document, apply function, superficial set document+superficialUpdateDocument :: (a -> a) -> PersistentDocument a -> IO ()+superficialUpdateDocument fun pDocRef =+ do{ doc <- getDocument pDocRef+ ; superficialSetDocument (fun doc) pDocRef+ }++-- | Check whether closing the document is okay. If the document+-- is dirty, the user is asked whether he\/she wants to save the+-- changes. Returns False if this process is cancelled or fails+-- at any point.+isClosingOkay :: PersistentDocument a -> IO Bool+isClosingOkay pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; if not (dirty pDoc) then return True else+ do{ result <- saveChangesDialog pDoc+ ; case result of+ Nothing -> return False+ Just True ->+ do{ hasBeenSaved <- save pDocRef+ ; return hasBeenSaved+ }+ Just False -> return True+ }}++-- | Save should be called when "Save" is selected from the file menu.+-- If there is no file name yet, this function acts as if "Save as"+-- was called. It returns False if saving is cancelled or fails.+save :: PersistentDocument a -> IO Bool+save pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; case fileName pDoc of+ Nothing -> saveAs pDocRef+ Just name -> performSave name pDocRef+ }++-- | saveAs should be called when "Save As" is selected from the file menu.+-- A dialog is shown where the user can select a location to save document.+-- This function returns False if saving is cancelled or fails.+saveAs :: PersistentDocument a -> IO Bool+saveAs pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; mbfname <- saveAsDialog pDoc (fileName pDoc)+ ; case mbfname of+ Just fname -> performSave fname pDocRef+ Nothing -> return False+ }+++-- | The current document is stored in the future list+-- and the first element of the history list is taken+-- as the new document+undo :: PersistentDocument a -> IO ()+undo pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; when (not (null (history pDoc))) $+ do{ let (msg, newDirty, newDoc) = head (history pDoc)+ newPDoc = pDoc+ { document = newDoc+ , dirty = newDirty+ , history = tail (history pDoc)+ , future = (msg, dirty pDoc, document pDoc) : future pDoc+ }+ ; writeIORef pDocRef newPDoc+ ; updateGUI pDocRef+ }}++-- | The current document is stored in the history list+-- and the first element of the future list is taken+-- as the new document+redo :: PersistentDocument a -> IO ()+redo pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; when (not (null (future pDoc))) $+ do{ let (msg, newDirty, newDoc) = head (future pDoc)+ newPDoc = pDoc+ { document = newDoc+ , dirty = newDirty+ , future = tail (future pDoc)+ , history = (msg, dirty pDoc, document pDoc) : history pDoc+ }+ ; writeIORef pDocRef newPDoc+ ; updateGUI pDocRef+ }}++-- FUNCTIONS THAT ARE NOT EXPORTED++updateIORef :: IORef a -> (a -> a) -> IO ()+updateIORef var fun = do { x <- readIORef var; writeIORef var (fun x) }++-- Perform the actual save to disk. If this fails False is returned+-- otherwise the file name is set and the dirty bit is cleared. The+-- dirty bits of history and future documents are set.+performSave :: String -> PersistentDocument a -> IO Bool+performSave name pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; hasBeenSaved <- (saveToDisk pDoc) name (document pDoc)+ ; if not hasBeenSaved then return False else+ do{ writeIORef pDocRef (pDoc { fileName = Just name })+ ; updateDirtyBitsOnSave pDocRef+ ; updateGUI pDocRef+ ; return True+ }}++-- updateDirtyBitsOnSave clears the dirty bit for the+-- current document and sets the dirty bits of all+-- documents in history and future lists+updateDirtyBitsOnSave :: PersistentDocument a -> IO ()+updateDirtyBitsOnSave pDocRef =+ updateIORef pDocRef (\pDoc -> pDoc+ { history = map makeDirty (history pDoc)+ , future = map makeDirty (future pDoc)+ , dirty = False+ })+ where+ makeDirty (msg, _, doc) = (msg, True, doc)++-- Shorthand to call all call-backs that update the GUI+updateGUI :: PersistentDocument a -> IO ()+updateGUI pDocRef =+ do{ pDoc <- readIORef pDocRef+ ; case history pDoc of+ [] -> updateUndo pDoc False ""+ ((msg, _, _):_) -> updateUndo pDoc True msg+ ; case future pDoc of+ [] -> updateRedo pDoc False ""+ ((msg, _, _):_) -> updateRedo pDoc True msg+ ; updateSave pDoc (dirty pDoc)+ ; updateTitleBar pDoc (fileName pDoc) (dirty pDoc)+ }
+ src/Ports.hs view
@@ -0,0 +1,117 @@+module Ports + ( Port+ , Ports+ , PortName+ , PortZone(..)++ , isTheSameAs+ , isInterfacePort+ , drawPorts+ , drawPort + , drawFig + , drawPrincipalPort + , portZone + , isUp+ ) where++import Math+import Constants+import Shape+import CommonIO+import Colors+import Graphics.UI.WX as WX+import Graphics.UI.WXCore++{- | 'Ports' represents the extra information for a generalization of nodes in which a node have special points where it can conect with other nodes (more conrrectly the ports of other nodes). ++Each port is represented by its name and a point relative to the center of node shape.+-}++type PortName = String+type Port = (PortName, DoublePoint)++type Ports = [Port]++-- | Equality on ports. Right now it is exactly the same as @(==)@.+isTheSameAs :: Port -> Port -> Bool+isTheSameAs = (==)++isInterfacePort :: PortName -> Bool+isInterfacePort = (== "interface")++drawPorts :: Size -> DC () -> DoublePoint -> Ports -> [Prop (DC ())] -> IO ()+drawPorts ppi dc centre ports options = + case ports of + [("interface",position)] -> drawPrincipalPort ppi dc centre optionsIP position+ p -> when (not $ null p)+ (if hasPrincipalPorts+ then do drawPrincipalPort ppi dc centre optionsPP (snd $ head p)+ mapM_ ( drawPort ppi dc centre optionsP . snd ) (tail p)+ else mapM_ ( drawPort ppi dc centre optionsP . snd ) p+ )++ where options' = [ brushKind := BrushSolid ] ++ options+ optionsP = [ brushColor := kPortBrushColor+ , penColor := kPortPenColor + ] ++ options'+ optionsPP = [ brushColor := kPrincipalPortBrushColor + , penColor := kPrincipalPortPenColor + ] ++ options'+ optionsIP = [ brushColor := kInterfacePortBrushColor + , penColor := kInterfacePortPenColor + ] ++ options'++drawPort :: Size -> DC () -> DoublePoint -> [Prop (DC ())] -> DoublePoint -> IO ()+drawPort ppi dc centre options point =+ WX.circle dc + (logicalToScreenPoint ppi $ translate centre point)+ (logicalToScreenX ppi kPortRadius)+ options++drawPrincipalPort :: Size -> DC () -> DoublePoint -> [Prop (DC ())] -> DoublePoint -> IO ()+drawPrincipalPort ppi dc centre options point = + WX.polygon dc points options+ where centro = logicalToScreenPoint ppi $ translate centre point+ param = kPrincipalPortSize+ points = + [ pointMove (vector param param) centro+ , pointMove (vector param (- param)) centro+ , pointMove (vector (- param) (- param)) centro+ , pointMove (vector (- param) param) centro+ ]++drawFig :: DC () -> Rect -> Shape -> Ports -> [Prop (DC ())] -> IO ()+drawFig dc r shape ports options = + do{+ -- Scale if the DC we are drawing to has a different PPI from the screen+ ; dcPPI <- dcGetPPI dc+ ; screenPPI <- getScreenPPI+ ; when (dcPPI /= screenPPI) $+ dcSetUserScale dc+ (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))+ (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))++ -- Set font+ ; set dc [ fontFamily := FontDefault, fontSize := 10 ]++ ; let ppi = screenPPI+ -- center of drawing area+ center = screenToLogicalPoint ppi $ rectCentralPoint r ++ ; logicalDraw ppi dc center shape options+ ; drawPorts ppi dc center ports options+ }+++data PortZone = Ztop | Zbottom | Zleft | Zright deriving (Show)++-- | Divides the 2D space with y=x and y=-x rects +portZone :: Port -> PortZone+portZone (_, DoublePoint x y) | y > x && y <= -x = Zleft+ | y >= x && y > -x = Zbottom+ | y < x && y >= -x = Zright+ | y <= x && y < -x = Ztop++-- | A different division in 2D space; the port is in the upper part of the node?+isUp :: Port -> Bool+isUp (_, DoublePoint _ y) = y <= 0
+ src/SafetyNet.hs view
@@ -0,0 +1,24 @@+module SafetyNet where++import Graphics.UI.WX hiding (window)+import Prelude hiding (catch)+import Control.Exception+import Constants (toolName)++safetyNet :: Window a -> IO b -> IO ()+safetyNet window computation =+ do{ catch+ (do { computation; return () })+ (handler window)+ ; return ()+ }++handler :: Window a -> Exception -> IO ()+handler window exception =+ do{ putStrLn $ "SafetyNet exception: " ++ show exception+ ; errorDialog window "Exception"+ ( "An exception occurred; please report the following text exactly to the makers: \n\n"+ ++ show exception ++ "\n\n"+ ++ "Please save the document under a different name and quit " ++ toolName ++ "."+ )+ }
+ src/Shape.hs view
@@ -0,0 +1,313 @@+module Shape where++import CommonIO+import Graphics.UI.WX as WX+import Graphics.UI.WXCore hiding (Colour)+import Graphics.UI.WXCore.Draw+import Math+import Text.Parse+--import Text.XML.HaXml.XmlContent+--import NetworkFile++import Colors+import Constants+import Common (removeQuotes) ++data Shape =+ Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double }+ | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }+ -- centred on (0,0)+ | Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }+ -- no fill for open shape+ | Points { shapeStyle :: ShapeStyle, shapePoints :: [DoublePoint] }+ | Rectangle { shapeStyle :: ShapeStyle+ , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }+ | Arc { shapeStyle :: ShapeStyle, shapeRadius :: Double+ , shapeStart :: Double, shapeEnd :: Double+ , shapeCenter :: DoublePoint }+ | Ellipse { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint+ , shapeHRadius :: Double, shapeVRadius :: Double }+ | EllipticArc { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint+ , shapeHRadius :: Double, shapeVRadius :: Double + , shapeStart :: Double, shapeEnd :: Double }+ | RoundRec { shapeStyle :: ShapeStyle, shapeRadius :: Double+ , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }+ | Text { shapeStyle :: ShapeStyle, shapeText :: String }+ | Composite { shapeSegments :: [Shape] } -- drawn in given order+ | TextInEllipse { shapeStyle :: ShapeStyle, shapeText :: String }+ deriving (Eq, Show, Read)++data ShapeStyle = ShapeStyle+ { styleStrokeWidth :: Int+ , styleStrokeColour :: Colour+ , styleFill :: Colour+ }+ deriving (Eq, Show, Read)++instance Parse Shape where+ parse = oneOf+ [ do{ isWord "Circle"+ ; return Circle+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeRadius"+ `discard` isWord "}"+ }+ , do{ isWord "Polygon"+ ; return Polygon+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapePerimeter"+ `discard` isWord "}"+ }+ , do{ isWord "Lines"+ ; return Lines+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapePerimeter"+ `discard` isWord "}"+ }+ , do{ isWord "Points"+ ; return Points+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapePoints"+ `discard` isWord "}"+ }+ , do{ isWord "Rectangle"+ ; return Rectangle+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeUpperLeft"+ `discard` isWord "," `apply` field "shapeLowerRight"+ `discard` isWord "}"+ }+ , do{ isWord "Arc"+ ; return Arc+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeRadius"+ `discard` isWord "," `apply` field "shapeStart"+ `discard` isWord "," `apply` field "shapeEnd"+ `discard` isWord "," `apply` field "shapeCenter"+ `discard` isWord "}"+ }+ , do{ isWord "Ellipse"+ ; return Ellipse+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeCenter"+ `discard` isWord "," `apply` field "shapeHRadius"+ `discard` isWord "," `apply` field "shapeVRadius"+ `discard` isWord "}"+ }+ , do{ isWord "EllipticArc"+ ; return EllipticArc+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeCenter"+ `discard` isWord "," `apply` field "shapeHRadius"+ `discard` isWord "," `apply` field "shapeVRadius"+ `discard` isWord "," `apply` field "shapeStart"+ `discard` isWord "," `apply` field "shapeEnd"+ `discard` isWord "}"+ }+ , do{ isWord "RoundRec"+ ; return RoundRec+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeRadius"+ `discard` isWord "," `apply` field "shapeUpperLeft"+ `discard` isWord "," `apply` field "shapeLowerRight"+ `discard` isWord "}"+ }+ , do{ isWord "Text"+ ; return Text+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeText"+ `discard` isWord "}"+ }+ , do{ isWord "Composite"+ ; return Composite+ `discard` isWord "{" `apply` field "shapeSegments"+ `discard` isWord "}"+ }+ , do{ isWord "TextInEllipse"+ ; return TextInEllipse+ `discard` isWord "{" `apply` field "shapeStyle"+ `discard` isWord "," `apply` field "shapeText"+ `discard` isWord "}"+ }+ ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Points,Rectangle,Arc,Ellipse,EllipticArc,RoundRec,Text,Composite,TextInEllipse)")++instance Parse ShapeStyle where+ parse = do{ isWord "ShapeStyle"+ ; return ShapeStyle+ `discard` isWord "{" `apply` field "styleStrokeWidth"+ `discard` isWord "," `apply` field "styleStrokeColour"+ `discard` isWord "," `apply` field "styleFill"+ `discard` isWord "}"+ }++{-+instance HTypeable Shape where+ toHType s = Defined "Shape" [] [ Constr "Circle" [] []+ , Constr "Polygon" [] []+ , Constr "Lines" [] []+ , Constr "Composite" [] []+ ]+instance XmlContent Shape where+ toContents s@(Circle{}) =+ [ mkElemC "Circle" (toContents (shapeStyle s)+ ++ [mkElemC "radius" (toContents (shapeRadius s))]) ]+ toContents s@(Polygon{}) =+ [ mkElemC "Polygon" (toContents (shapeStyle s)+ ++ [mkElemC "perimeter" (concatMap toContents+ (shapePerimeter s))]) ]+ toContents s@(Lines{}) =+ [ mkElemC "Lines" (toContents (shapeStyle s)+ ++ [mkElemC "perimeter" (concatMap toContents+ (shapePerimeter s))]) ]+ toContents s@(Composite{}) =+ [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ]+ parseContents = do+ { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]+ ; case t of+ "Circle" -> interior e $+ do{ style <- parseContents+ ; r <- inElement "radius" parseContents+ ; return (Circle {shapeStyle=style, shapeRadius=r})+ }+ "Polygon" -> interior e $+ do{ style <- parseContents+ ; p <- inElement "perimeter" $ many1 parseContents+ ; return (Polygon {shapeStyle=style, shapePerimeter=p})+ }+ "Lines" -> interior e $+ do{ style <- parseContents+ ; p <- inElement "perimeter" $ many1 parseContents+ ; return (Lines {shapeStyle=style, shapePerimeter=p})+ }+ "Composite" -> interior e $ do{ ss <- many1 parseContents+ ; return (Composite {shapeSegments=ss})+ }+ }++instance HTypeable ShapeStyle where+ toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []]+instance XmlContent ShapeStyle where+ toContents s =+ [ mkElemC "ShapeStyle"+ [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s))+ , mkElemC "StrokeColour" (toContents (styleStrokeColour s))+ , mkElemC "Fill" (toContents (styleFill s))+ ]+ ]+ parseContents = inElement "ShapeStyle" $ do+ { w <- inElement "StrokeWidth" parseContents+ ; c <- inElement "StrokeColour" parseContents+ ; f <- inElement "Fill" parseContents+ ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c+ , styleFill=f })+ }+-}++logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO ()+logicalDraw ppi dc centre shape options =+ case shape of+ Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre)+ (logicalToScreenX ppi (shapeRadius shape))+ (style2options (shapeStyle shape)++options)++ Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi+ . translate centre)+ (shapePerimeter shape))+ (style2options (shapeStyle shape)++options)++ Lines {} -> logicalLineSegments ppi dc (map (translate centre)+ (shapePerimeter shape))+ (style2options (shapeStyle shape)++options)++ Points {} -> mapM_ (\p -> WX.drawPoint dc + (logicalToScreenPoint ppi $ translate centre p)+ (style2options (shapeStyle shape)++options)+ ) + $ shapePoints shape++ Rectangle {} -> WX.drawRect dc + (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )+ (style2options (shapeStyle shape)++options)++ Arc {} -> WX.arc dc (logicalToScreenPoint ppi . translate centre $ shapeCenter shape)+ (logicalToScreenX ppi (shapeRadius shape))+ (shapeStart shape)+ (shapeEnd shape)+ (style2options (shapeStyle shape)++options)++ Ellipse {} -> WX.ellipse dc+ (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))+ (style2options (shapeStyle shape)++options)++ EllipticArc {} -> WX.ellipticArc + dc+ (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))+ (shapeStart shape)+ (shapeEnd shape)+ (style2options (shapeStyle shape)++options)++ RoundRec {} -> WX.roundedRect dc + (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )+ (shapeRadius shape)+ (style2options (shapeStyle shape)++options)++ Text {} -> do textSize <- getTextExtent dc (shapeText shape)+ let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre+ . scale 0.5 + . screenToLogicalPoint ppi $ pointFromSize textSize+ WX.drawText dc (removeQuotes $ shapeText shape) + upperCorner+ (style2options (shapeStyle shape)++options)++ Composite {} -> mapM_ (\s-> logicalDraw ppi dc centre s options)+ (shapeSegments shape)++ TextInEllipse {} -> + do let txt = removeQuotes (shapeText shape) + textSize <- getTextExtent dc (shapeText shape)+ let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre+ . scale 0.5 + . screenToLogicalPoint ppi $ pointFromSize textSize+ WX.ellipse dc+ (rect (pointSub upperCorner $ Point 5 5) + $ Size (sizeW textSize + 10) (sizeH textSize + 10) )+ (style2options (shapeStyle shape)++options)+ WX.drawText dc txt upperCorner + (style2options (shapeStyle shape)++options)++ where rectFrom :: DoublePoint -> DoublePoint -> Rect+ rectFrom upperLeftCorner lowerRightCorner = + rectBetween (logicalToScreenPoint ppi $ translate centre upperLeftCorner)+ (logicalToScreenPoint ppi $ translate centre lowerRightCorner)+ doRect :: DoublePoint -> Double -> Double -> Rect+ doRect ellipseCenter hRadius vRadius = + rectBetween (logicalToScreenPoint ppi . translate centre + $ subtractDoublePoint ellipseCenter $ DoublePoint hRadius vRadius)+ (logicalToScreenPoint ppi . translate centre + $ translate ellipseCenter $ DoublePoint hRadius vRadius)++logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()+logicalLineSegments _ _ [_p] _options = return ()+logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =+ do{ line dc (logicalToScreenPoint ppi fromPoint)+ (logicalToScreenPoint ppi toPoint) options+ ; logicalLineSegments ppi dc (toPoint:ps) options+ }++circle :: Shape+circle = Circle { shapeStyle = defaultShapeStyle+ , shapeRadius = kNODE_RADIUS }++style2options :: ShapeStyle -> [Prop (DC ())]+style2options sty =+ [ penWidth := styleStrokeWidth sty+ , penColor := wxcolor (styleStrokeColour sty)+ , brushKind := BrushSolid+ , brushColor := wxcolor (styleFill sty)+ ]++defaultShapeStyle :: ShapeStyle+defaultShapeStyle =+ ShapeStyle { styleStrokeWidth = 1+ , styleStrokeColour = licorice+ , styleFill = nodeColor }
+ src/SpecialSymbols.hs view
@@ -0,0 +1,111 @@+module SpecialSymbols where++import Shape+import Palette+import Ports+import Colors+import Math++-- | List of Special Symbols.+specialSymbols, managementSymbols :: Palette n+specialSymbols =+ Palette $ interfaceSymbol : shapes managementSymbols++managementSymbols =+ Palette [ copySymbol+ , duplicatorSymbol+ , eraseSymbol+ ]+interfaceSymbol, copySymbol, duplicatorSymbol, eraseSymbol :: (ShapeName, (Shape, Ports, Maybe a))+interfaceSymbol =+ ( "interface"+ , ( Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = coconut+ , styleFill = coconut+ }+ , shapeRadius = 0.25+ }+ , [("interface",DoublePoint 0.0 0.25)]+ , Nothing+ )+ )++copySymbol =+ ( "copy"+ , ( TextInEllipse { shapeStyle = ShapeStyle { styleStrokeWidth = 1+ , styleStrokeColour = licorice+ , styleFill = silver+ }+ , shapeText = "c"+ }+ , [("src",DoublePoint 0.0 0.3),("fst_target",DoublePoint (-0.3) (-0.3)),("snd_target",DoublePoint 0.3 (-0.3))]+ , Nothing+ )+ )++duplicatorSymbol =+ ( "duplicator"+ , ( Composite { shapeSegments = [ Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.5+ }+ , Arc { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.2+ , shapeStart = 70.0+ , shapeEnd = 270.0+ , shapeCenter = DoublePoint 0.0 (-0.18)+ }+ , Arc { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.2+ , shapeStart = 150.0+ , shapeEnd = 90.0+ , shapeCenter = DoublePoint 0.0 0.18+ }+ ]+ }+ , [("down",DoublePoint 0.0 0.5),("copy1",DoublePoint (-0.3) (-0.3)),("copy2",DoublePoint 0.3 (-0.3))]+ , Nothing+ )+ )++eraseSymbol =+ ( "Erase"+ , ( Composite { shapeSegments = [ Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.5+ }+ , Arc { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.2+ , shapeStart = 90.0+ , shapeEnd = 270.0+ , shapeCenter = DoublePoint 0.0 (-0.18)+ }+ , Arc { shapeStyle = ShapeStyle { styleStrokeWidth = 2+ , styleStrokeColour = RGB 250 0 0+ , styleFill = coconut+ }+ , shapeRadius = 0.2+ , shapeStart = 90.0+ , shapeEnd = 270.0+ , shapeCenter = DoublePoint 0.0 0.18+ }+ ]+ }+ , [("down",DoublePoint 0.0 0.5)]+ , Nothing+ )+ )+
+ src/State.hs view
@@ -0,0 +1,248 @@+module State+ ( State+ , State.empty+ , ToolWindow(..)++ , getDocument+ , getDragging, setDragging+ , getCanvas, setCanvas+ , getLHSCanvas, setLHSCanvas+ , getRHSCanvas, setRHSCanvas+ , getPalettePanel, setPalettePanel+ , getNetworkFrame, setNetworkFrame+ , getPageSetupDialog, setPageSetupDialog+ , getDisplayOptions, setDisplayOptions+ , changeDisplayOptions+ , getCurrentShape, setCurrentShape+ , getActiveCanvas, setActiveCanvas+ , getActiveRule, setActiveRule+ , getTree, setTree+ , getShape1, setShape1+ , getShape2, setShape2+ , getOkButton, setOkButton+ , getReduceButton, setReduceButton+ , getContinueReduction, setContinueReduction++ , stopReduction+ , disableReduce+ ) where++import Document+import Math+import qualified PersistentDocument as PD+import DisplayOptions++import Graphics.UI.WX+import Graphics.UI.WXCore hiding (Document, ToolWindow)++ ++type State g n e = Var (StateRecord g n e)++data StateRecord g n e = St+ { stDocument :: PD.PersistentDocument (Document g n e)+ , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node)+ , stNetworkFrame :: Frame ()+ , stCanvas :: ScrolledWindow ()+ , stLHSCanvas :: ScrolledWindow ()+ , stRHSCanvas :: ScrolledWindow ()+ , stPalettePanel :: Panel ()+ , stPageSetupDialog :: PageSetupDialog ()+ , stDisplayOptions :: DisplayOptions+ , stShape :: String -- ^ the name of the shape in the palette+ , stActiveCanvas :: ActiveCanvas -- ^ which canvas is active+ , stActiveRule :: RuleName -- ^ a interaction rule's name + , stTree :: TreeCtrl () -- ^ the treeCtrl that lists the rules+ , stShape1 :: Maybe String -- ^ a shape name+ , stShape2 :: Maybe String -- ^ a shape name+ , stOkButton :: Button () + , stReduceButton :: Button () + , stContinueReduct :: Bool -- ^ reduction process should continue or stop + }++data ToolWindow = TW+ { twRepaint :: IO ()+ , twFrame :: Frame ()+ }++empty :: IO (State g n e)+empty =+ do{ dummy <- PD.dummy++ ; varCreate (St+ { stDocument = dummy+ , stNetworkFrame = error "State.empty: network frame has not been set"+ , stDragging = Nothing+ , stCanvas = error "State.empty: canvas has not been set"+ , stLHSCanvas = error "State.empty: canvasLHS has not been set"+ , stRHSCanvas = error "State.empty: canvasRHS has not been set"+ , stPalettePanel = error "State.empty: panel has not been set"+ , stPageSetupDialog = error "State.empty: page setup dialog has not been set"+ , stDisplayOptions = DisplayOptions.standard+ , stShape = "circle"+ , stActiveCanvas = Net+ , stShape1 = Nothing+ , stShape2 = Nothing+ , stOkButton = error "State.empty: Ok button has not been set" + , stReduceButton = error "State.empty: Reduce button has not been set"+ , stContinueReduct = True+ })+ }++-- Getters++getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e))+getDocument = getFromState stDocument++getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint))+getDragging = getFromState stDragging++getNetworkFrame :: State g n e -> IO (Frame ())+getNetworkFrame = getFromState stNetworkFrame++getCanvas :: State g n e -> IO (ScrolledWindow ())+getCanvas = getFromState stCanvas++getLHSCanvas :: State g n e -> IO (ScrolledWindow ())+getLHSCanvas = getFromState stLHSCanvas++getRHSCanvas :: State g n e -> IO (ScrolledWindow ())+getRHSCanvas = getFromState stRHSCanvas++getPalettePanel :: State g n e -> IO (Panel ())+getPalettePanel = getFromState stPalettePanel++getPageSetupDialog :: State g n e -> IO (PageSetupDialog ())+getPageSetupDialog = getFromState stPageSetupDialog++getDisplayOptions :: State g n e -> IO DisplayOptions+getDisplayOptions = getFromState stDisplayOptions++getCurrentShape :: State g n e -> IO String+getCurrentShape = getFromState stShape++getActiveCanvas :: State g n e -> IO ActiveCanvas+getActiveCanvas = getFromState stActiveCanvas++getActiveRule :: State g n e -> IO RuleName+getActiveRule = getFromState stActiveRule++getTree :: State g n e -> IO (TreeCtrl () )+getTree = getFromState stTree++getShape1 :: State g n e -> IO (Maybe String )+getShape1 = getFromState stShape1++getShape2 :: State g n e -> IO (Maybe String )+getShape2 = getFromState stShape2++getOkButton :: State g n e -> IO (Button () )+getOkButton = getFromState stOkButton++getReduceButton :: State g n e -> IO (Button () )+getReduceButton = getFromState stReduceButton++getContinueReduction :: State g n e -> IO Bool+getContinueReduction = getFromState stContinueReduct+++-- Setters++setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO ()+setDragging theDragging stateRef =+ varUpdate_ stateRef (\state -> state { stDragging = theDragging })++setNetworkFrame :: Frame () -> State g n e -> IO ()+setNetworkFrame networkFrame stateRef =+ varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame })++setCanvas :: ScrolledWindow () -> State g n e -> IO ()+setCanvas canvas stateRef =+ varUpdate_ stateRef (\state -> state { stCanvas = canvas })++setLHSCanvas :: ScrolledWindow () -> State g n e -> IO ()+setLHSCanvas canvas stateRef =+ varUpdate_ stateRef (\state -> state { stLHSCanvas = canvas })++setRHSCanvas :: ScrolledWindow () -> State g n e -> IO ()+setRHSCanvas canvas stateRef =+ varUpdate_ stateRef (\state -> state { stRHSCanvas = canvas })++setPalettePanel :: Panel () -> State g n e -> IO ()+setPalettePanel panel stateRef =+ varUpdate_ stateRef (\state -> state { stPalettePanel = panel })++setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO ()+setPageSetupDialog thePageSetupDialog stateRef =+ varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog })++setDisplayOptions :: DisplayOptions -> State g n e -> IO ()+setDisplayOptions dp stateRef =+ varUpdate_ stateRef (\state -> state { stDisplayOptions = dp })++changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO ()+changeDisplayOptions dpf stateRef =+ varUpdate_ stateRef+ (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) })++setCurrentShape :: String -> State g n e -> IO ()+setCurrentShape shapeName stateRef =+ varUpdate_ stateRef (\state -> state { stShape = shapeName })++setActiveCanvas :: ActiveCanvas -> State g n e -> IO ()+setActiveCanvas activeCanvas stateRef =+ do rule <- getActiveRule stateRef+ let activeCanvas' = case activeCanvas of+ Net -> Net+ LHS str | null str -> LHS rule+ | otherwise -> LHS str+ RHS str | null str -> RHS rule+ | otherwise -> RHS str+ varUpdate_ stateRef (\state -> state { stActiveCanvas = activeCanvas' })++setActiveRule :: RuleName -> State g n e -> IO ()+setActiveRule activeRule stateRef =+ varUpdate_ stateRef (\state -> state { stActiveRule = activeRule })++setTree :: TreeCtrl () -> State g n e -> IO ()+setTree tree stateRef =+ varUpdate_ stateRef (\state -> state { stTree = tree })++setShape1 :: Maybe String -> State g n e -> IO ()+setShape1 shape1 stateRef =+ varUpdate_ stateRef (\state -> state { stShape1 = shape1 })++setShape2 :: Maybe String -> State g n e -> IO ()+setShape2 shape2 stateRef =+ varUpdate_ stateRef (\state -> state { stShape2 = shape2 })++setOkButton :: Button () -> State g n e -> IO ()+setOkButton okButton stateRef =+ varUpdate_ stateRef (\state -> state { stOkButton = okButton })++setReduceButton :: Button () -> State g n e -> IO ()+setReduceButton reduceButton stateRef =+ varUpdate_ stateRef (\state -> state { stReduceButton = reduceButton })++setContinueReduction :: Bool -> State g n e -> IO ()+setContinueReduction continue stateRef =+ varUpdate_ stateRef (\state -> state { stContinueReduct = continue })+--++disableReduce :: State g n e -> IO ()+disableReduce state = return ()+-- do button <- getReduceButton state+-- set button [enabled := False]++stopReduction :: State g n e -> IO ()+stopReduction = setContinueReduction False++-- Utility functions++getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a+getFromState selector stateRef = do+ state <- varGet stateRef+ return (selector state)++varUpdate_ :: Var a -> (a -> a) -> IO ()+varUpdate_ var fun = do { varUpdate var fun; return () }
+ src/StateUtil.hs view
@@ -0,0 +1,30 @@+module StateUtil+ ( repaintAll+ , getNetworkName+ ) where++import State+import Common+import qualified PersistentDocument as PD++import Data.Maybe+import Graphics.UI.WX++repaintAll :: State g n e -> IO ()+repaintAll state =+ do{ canvas <- getCanvas state+ ; canvasLHS <- getLHSCanvas state+ ; canvasRHS <- getRHSCanvas state+ ; Graphics.UI.WX.repaint canvas+ ; Graphics.UI.WX.repaint canvasLHS+ ; Graphics.UI.WX.repaint canvasRHS+ }++getNetworkName :: State g n e -> IO String+getNetworkName state =+ do { pDoc <- getDocument state+ ; mFilename <- PD.getFileName pDoc+ ; case mFilename of+ Just filename -> return $ removeExtension filename+ Nothing -> return "Untitled"+ }