cash (empty) → 0.1.0.0
raw patch · 23 files changed
+4422/−0 lines, 23 filesdep +HaXmldep +basedep +deepseqsetup-changedbinary-added
Dependencies added: HaXml, base, deepseq, haskell98, network, parallel, pretty
Files
- Setup.hs +3/−0
- cash.cabal +28/−0
- misc/SCSCP.dtd +75/−0
- misc/id512.g +47/−0
- misc/idperm.g +33/−0
- misc/karatsuba.g +522/−0
- misc/runit.g +62/−0
- misc/sample-sgprc +2/−0
- misc/sgp_admin.sh +161/−0
- misc/sgp_client.g +139/−0
- misc/sgp_server.g +300/−0
- misc/sumEuler.g +87/−0
- src/Math/ComputerAlgebra/.Cash.hs.swp binary
- src/Math/ComputerAlgebra/Cash.hs +376/−0
- src/Math/ComputerAlgebra/Cash/BaseServices.hs +129/−0
- src/Math/ComputerAlgebra/Cash/CA_Skeletons.hs +302/−0
- src/Math/ComputerAlgebra/Cash/Date.hs +10/−0
- src/Math/ComputerAlgebra/Cash/HS2SCSCP.hs +214/−0
- src/Math/ComputerAlgebra/Cash/HS_SCSCP.lhs +1123/−0
- src/Math/ComputerAlgebra/Cash/Monitor.hs +112/−0
- src/Math/ComputerAlgebra/Cash/SCSCP_API.hs +433/−0
- src/Math/ComputerAlgebra/Cash/SCSCP_DTD.hs +245/−0
- src/Math/ComputerAlgebra/Cash/SGPTypes.hs +19/−0
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ cash.cabal view
@@ -0,0 +1,28 @@+Name: cash+Version: 0.1.0.0+Author: Chris Brown, Hans-Wolfgang Loidl, Jost Berthold, Kevin Hammond+Maintainer: Chris Brown+Stability: Provisional+License: BSD3+Bug-Reports: mailto:chrisb@cs.st-andrews.ac.uk+Homepage: http://www.cs.st-andrews.ac.uk/~hwloidl/SCIEnce/SymGrid-Par/CASH/+Description: A Computer Algebra Shell for Haskell. CASH connects via SCSCP and OpenMATH to Computer Algebra systems with SCSCP (such as GAP). CASH also exposes an OpenMath and SCSCP marshalling library.+Synopsis: the Computer Algebra SHell+Category: Math, Computer Algebra+Cabal-Version: >= 1.6+Build-Type: Simple+Data-Dir: misc+Data-Files: *.g, sample-sgprc, sgp_admin.sh+extra-source-files: SCSCP/BaseServices.hs+Library+ Build-Depends: base >4 && <= 5, network, parallel, HaXml <= 1.13.3, pretty, haskell98, deepseq+ Exposed-modules: Math.ComputerAlgebra.Cash+ Math.ComputerAlgebra.Cash.BaseServices+ Math.ComputerAlgebra.Cash.SCSCP_API+ Math.ComputerAlgebra.Cash.HS_SCSCP+ Math.ComputerAlgebra.Cash.SGPTypes+ Math.ComputerAlgebra.Cash.Date+ Math.ComputerAlgebra.Cash.HS2SCSCP+ Math.ComputerAlgebra.Cash.Monitor+ Math.ComputerAlgebra.Cash.SCSCP_DTD+ hs-source-dirs: src
+ misc/SCSCP.dtd view
@@ -0,0 +1,75 @@+<!-- Reduced DTD for OpenMath, suitable to + decribe all kinds of SCSCP messages, leaving + out the computation data (described as "DUMMY").++ Purpose: generate (and modify!) Haskell source code + to parse and fill an appropriate data structure.++ Author: Jost Berthold, University of St.Andrews, UK+ (c) 12/2008, SCIEnce project.++ -->++<!ELEMENT OMOBJ (OMATTR)>+<!-- not true for mocking server + call_ID missing from error messages+ => OMATTR missing, directly OMA inside OMOBJ+<!ELEMENT OMOBJ (OMATTR | OMA )>+-->+<!-- and the kant server is adding loads of boring xml garbage:+xmlns:OM=\"http://www.openmath.org/OpenMath\" xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:schemaLocation=\"http://www.openmath.org/OpenMath http://www.openmath.org/standard/om20-2004-06-30/openmath2.xsd\" version=\"2.0\"> -->+<!ATTLIST OMOBJ xmlns:OM CDATA #IMPLIED+ xmlns:xsi CDATA #IMPLIED+ xsi:schemaLocation CDATA #IMPLIED+ version CDATA #IMPLIED+ >++<!ELEMENT OMATTR (OMATP?,OMA)>+<!ELEMENT OMS EMPTY>+<!ATTLIST OMS cd CDATA #REQUIRED+ name CDATA #REQUIRED >+<!ELEMENT OMATP (((OMS,OMSTR)|(OMS,OMI))*)>++<!-- caution: OMR/OME must come before the all-purpose EATALL -->+<!ELEMENT OMA ((OMS,OMR) | (OMS,OME) | (OMS,EATALL) )>+<!ELEMENT OME (OMS,OMSTR)>+<!-- not true for mocking server + (IMHO against spec.!!!)+ server returns OMA OMS (list) OMSTR OMSTR OMSTR OMSTR for invalid name+<!ELEMENT OME (OMS, ANY )> (!!!)+-->+<!ELEMENT OMSTR ( #PCDATA )>+<!ELEMENT OMI ( #PCDATA )>+<!ELEMENT OMR EMPTY>+<!ATTLIST OMR xref CDATA #REQUIRED>++<!-- this is wrong, but will be edited away later -->+<!ELEMENT EATALL ( ANY* ) >+++<!--+{- the SCSCP messages always nest like this:+ <OMOBJ>+ <OMATTR>+ <OMATP>+ -attributes- (sequence of paired OMS and OMsomething)+ </OMATP>+ <OMA>+ <OMS cd="scscp1" name=-whatItWas- />+ -needed content for what it was-+ </OMA>+ </OMATP>+ </OMATTR>+ </OMOBJ>++-whatItWas- -needed/supplied content+"procedure call" <OMA><OMS cd="SCSCP_transient_identifier"+ name=-nameOfTheRegisteredProcedure- />+ -arguments-</OMA>+"procedure_completed" -theResult- (always one)+ can be anything, including a reference + <OMR xref="blabla" />+"procedure terminated" <OME><OMS cd="scscp1" name=-theErrorClass-/>+ <OMSTR>-errorText-</OMSTR></OME>+-}+-->
+ misc/id512.g view
@@ -0,0 +1,47 @@+# $Id: id512.g 2846 2009-04-18 23:25:47Z alexk $++IdGroup512:=function( G )+# this is the client's counterpart for the SCSCP service for the +# identification of groups of order 512 using the ANUPQ package. +# (See the procedure IdGroup512ByCode in scscp/example/myserver.g).+# The group must have PC presentation and its pcgs code will be +# sent to the server to identify the group.+local code, result;+if Size( G ) <> 512 then+ Error( "G must be a group of order 512 !!!\n" );+fi;+code := CodePcGroup( G );+result := EvaluateBySCSCP( "IdGroup512ByCode", [ code ], + "localhost", 26133 );+return result.object;+end;++IdGroup512:=function( G )+# this is the client's counterpart for the SCSCP service for the +# identification of groups of order 512 using the ANUPQ package. +# (See the procedure IdGroup512ByCode in scscp/example/myserver.g).+# The group must have PC presentation and its pcgs code will be +# sent to the server to identify the group.+local code, result;+if Size( G ) <> 512 then+ Error( "G must be a group of order 512 !!!\n" );+fi;+code := CodePcGroup( G );+result := EvaluateBySCSCP( "IdGroup512ByCode", [ code ], + "localhost", 26133 );+ # "chrystal.mcs.st-and.ac.uk", 26133 );+return result.object;+end;+++TestIdGroup512:=function( nrcalls )+# This is the test to generate a sequence of calls to the+# previous function, the length of this sequence is the+# input parameter nrcalls of the test+local numbers, n, G;+for n in [ 1 .. nrcalls ] do+ G := SmallGroup( 512, n );+ Print( "Sending ", IdGroup( G ), " ... \n" );+ Print( "Got back ", IdGroup512( G ), "\n" );+od;+end;
+ misc/idperm.g view
@@ -0,0 +1,33 @@+# $Id: idperm.g 2846 2009-04-18 23:25:47Z alexk $++IdGroupWS := function( G )+# this is the client's counterpart for the SCSCP service for the +# indentification of groups in the GAP Small Groups Library.+# (See the procedure GroupIdentificationService in scscp/example/myserver.g)+# The group is converted to the permutation group and then its generators+# will be sent to the server for the identification.+local H, result;+if not IsPermGroup(G) then+ H:= Image( IsomorphismPermGroup( G ) );+else+ H := G;+fi; +result := EvaluateBySCSCP ( "GroupIdentificationService", + [ GeneratorsOfGroup(H) ], + "localhost", 26133 );+return result.object;+end;++TestIdGroupWS:=function( nrcalls )+# This is the test to generate a sequence of calls to the+# previous function, the length of this sequence is the+# input parameter nrcalls of the test+local k, s, n, G;+for k in [1..nrcalls] do+s := Random( [ 1 .. 1000 ] );+n := Random( [ 1 ..NrSmallGroups(s)]);+G := SmallGroup( s, n );+Print( "Sending ", IdGroup( G ), " ... \n" );+Print( "Got back ", IdGroupWS( G ), "\n" );+od;+end;
+ misc/karatsuba.g view
@@ -0,0 +1,522 @@+#############################################################################+#+# This is straightforward implementation of Karatsuba multiplication for+# integers. It is used to demonstrate the algorithm using the GAP language,+# and not suitable for practical implementation, because it is slow by a+# number of reasons.+#+KaratsubaMultiplication:=function( x, y )+local n, b, x1, x2, y1, y2, u, v, w;+if x < 10 and y < 10 then+ return x*y;+else+ n:=Int( Length ( String ( Maximum( x, y ) ) ) / 2 );+ b := 10^n;+ x1 := Int( x / b );+ x2 := x mod b;+ y1 := Int( y / b );+ y2 := y mod b;+ u := KaratsubaMultiplication(x1,y1);+ v := KaratsubaMultiplication(x2,y2);+ w := KaratsubaMultiplication(x1+x2,y1+y2);+ return u*(b^2) + (w-u-v)*b + v;+fi; +end;+++#############################################################################+#+# This is straightforward implementation of Karatsuba multiplication for+# polynomials. It is used to demonstrate the algorithm using the GAP language,+# and not suitable for practical implementation, because it is slow by a+# number of reasons.+#+KaratsubaPolynomialMultiplicationSlow:=function( f, g )+local deg, n, x, b, f1, f0, g1, g0, u, v, w;+if IsZero(f) or IsZero(g) then + return Zero(f);+fi;+deg := Maximum( List( [f,g], DegreeOfLaurentPolynomial ) );+n:=1;+while n < deg do+ n:=n*2;+od;+if n=1 then+ return f*g;+else+ x := IndeterminateOfUnivariateRationalFunction( f );+ b := x^(n/2);+ f1 := EuclideanQuotient( f, b );+ f0 := EuclideanRemainder( f, b );+ g1 := EuclideanQuotient( g, b );+ g0 := EuclideanRemainder( g, b );+ u := KaratsubaPolynomialMultiplicationSlow( f1, g1 );+ v := KaratsubaPolynomialMultiplicationSlow( f0, g0 );+ w := KaratsubaPolynomialMultiplicationSlow( f1+f0, g1+g0 );+ return u*(b^2) + (w-u-v)*b + v;+fi; +end;+++#############################################################################+#+# This implementation of Karatsuba multiplication for polynomials is faster+# than the previous, because it uses internal representation of polynomials+# for fast finding Euclidean quotient and remainder, and fast multiplying+# by x^(n/2) and x^n. Nevertheless, it is not fully efficient, since it+# uses explicit polynomials as arguments in recursive calls.+#+KaratsubaPolynomialMultiplicationBetter:=function( f, g )+local deg, n, halfn, x, b, nr, fam, f1, f0, g1, g0, u, v, w, + cf, cf1, cf0, cg, cg1, cg0, k, pos, val,+ cu, ub2, cwuv, wuvb;+if IsZero(f) or IsZero(g) then + return Zero(f);+fi;+deg := Maximum( List( [f,g], DegreeOfLaurentPolynomial ) );+n:=1;+while n < deg do+ n:=n*2;+od;+if n=1 then+ return f*g;+else+ halfn := n/2;+ x := IndeterminateOfUnivariateRationalFunction( f );+ b := x^(halfn);+ nr := IndeterminateNumberOfLaurentPolynomial(f); + fam := FamilyObj( 1 );+ if DegreeOfLaurentPolynomial(f) >= halfn then+ cf := CoefficientsOfLaurentPolynomial( f );+ k:=halfn-cf[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + cf1 := cf[1]{[ pos .. Length(cf[1])]};+ f1 := LaurentPolynomialByCoefficients( fam, cf1, val, nr ); # EuclideanQuotient( f, b )+ cf0 := cf[1]{[ 1 .. halfn-cf[2] ]};+ f0 := LaurentPolynomialByCoefficients( fam, cf0, cf[2], nr ); # EuclideanRemainder( f, b )+ else+ f1:=Zero(f);+ f0:=f;+ fi;+ if DegreeOfLaurentPolynomial(g) >= halfn then+ cg := CoefficientsOfLaurentPolynomial( g );+ k:=halfn-cg[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + cg1 := cg[1]{[ pos .. Length(cg[1])]};+ g1 := LaurentPolynomialByCoefficients( fam, cg1, val, nr ); # EuclideanQuotient( g, b )+ cg0 := cg[1]{[ 1 .. halfn-cg[2] ]};+ g0 := LaurentPolynomialByCoefficients( fam, cg0, cg[2], nr ); # EuclideanRemainder( g, b )+ else+ g1:=Zero(g);+ g0:=g;+ fi; + u := KaratsubaPolynomialMultiplicationBetter(f1,g1);+ v := KaratsubaPolynomialMultiplicationBetter(f0,g0);+ w := KaratsubaPolynomialMultiplicationBetter(f1+f0,g1+g0);+ cu := CoefficientsOfLaurentPolynomial( u );+ ub2 := LaurentPolynomialByCoefficients( fam, cu[1], cu[2]+n, nr );+ cwuv := CoefficientsOfLaurentPolynomial( w-u-v );+ wuvb := LaurentPolynomialByCoefficients( fam, cwuv[1], cwuv[2]+halfn, nr );+ return ub2 + wuvb + v;+fi; +end;++#############################################################################+#+# KARATSUBA MULTIPLICATION FOR POLYNOMIALS+#+#############################################################################++PlusLaurentPolynomialsExtRep := function( f, g )+local val, t, shift, i, j, ind, pos, pos1, k, zero;+if f[1]=[] then # f=0 + return g;+elif g[1]=[] then # g=0+ return f;+elif f[2]=g[2] then # f and g starts from monomials of the same degree+ val := f[2];+ t := f[1] + g[1];+elif f[2] < g [2] then # f starts earlier+ zero := Zero(f[1][1]);+ val := f[2];+ t := ShallowCopy(f[1]); + shift := g[2]-f[2];+ for j in [ Length(t) + 1 .. shift ] do+ t[j]:=zero;+ od;+ for i in [ 1 .. Length(g[1])] do+ ind := shift + i;+ if IsBound(t[ind]) then+ t[ind] := t[ind] + g[1][i];+ else+ t[ind] := g[1][i];+ fi; + od;+else # g starts earlier+ zero := Zero(f[1][1]);+ val := g[2];+ t := ShallowCopy(g[1]);+ shift := f[2]-g[2];+ for j in [ Length(t) + 1 .. shift ] do+ t[j]:=zero;+ od;+ for i in [ 1 .. Length(f[1])] do+ ind := shift + i;+ if IsBound(t[ind]) then+ t[ind] := t[ind] + f[1][i];+ else+ t[ind] := f[1][i];+ fi; + od; +fi; +# Final analysis, removing trailing zeroes from both sides+if t=[] then+ return [ [ ], 0 ];+else+ pos := PositionNonZero( t );+ if pos = Length(t)+1 then+ return [ [ ], 0 ];+ else+ pos1 := First([1..Length(t)], k -> t[Length(t)-k+1]<>0 );+ return [ t{[pos..Length(t)-pos1+1]}, val + pos -1 ];+ fi; +fi; +end;+++MinusLaurentPolynomialsExtRep := function( f, g )+local val, t, shift, i, j, ind, pos, pos1, k, zero;+if f[1]=[] then # f=0+ return [ -g[1], g[2] ];+elif g[1]=[] then # g=0+ return f;+elif f[2]=g[2] then # f and g starts from monomials of the same degree+ val := f[2];+ t := f[1] - g[1];+elif f[2] < g [2] then # f starts earlier+ zero := Zero(f[1][1]);+ val := f[2];+ t := ShallowCopy(f[1]);+ shift := g[2]-f[2];+ for j in [ Length(t) + 1 .. shift ] do+ t[j]:=zero;+ od;+ for i in [ 1 .. Length(g[1])] do+ ind := shift + i;+ if IsBound(t[ind]) then+ t[ind] := t[ind] - g[1][i];+ else+ t[ind] := -g[1][i];+ fi; + od;+else # g starts earlier+ zero := Zero(f[1][1]);+ val := g[2];+ t := -ShallowCopy(g[1]);+ shift := f[2]-g[2];+ for j in [ Length(t) + 1 .. shift ] do+ t[j]:=zero;+ od;+ for i in [ 1 .. Length(f[1])] do+ ind := shift + i;+ if IsBound(t[ind]) then+ t[ind] := t[ind] + f[1][i];+ else+ t[ind] := f[1][i];+ fi; + od; +fi; +# Final analysis, removing trailing zeroes from both sides+if t=[] then+ return [ [ ], 0 ];+else+ pos := PositionNonZero( t );+ if pos = Length(t)+1 then+ return [ [ ], 0 ];+ else+ pos1 := First([1..Length(t)], k -> t[Length(t)-k+1]<>0 );+ return [ t{[pos..Length(t)-pos1+1]}, val + pos - 1 ];+ fi; +fi; +end;++#############################################################################+# +# Must be >=3 for correct work. May depend on the coefficients field.+# For polynomials with integer coefficients, empirically determined+# optimal value is 48.+# +KARATSUBA_CUTOFF := 48; ++#############################################################################+#+# Here the input is the presentation of polynomials as it is produced by+# the function CoefficientsOfLaurentPolynomial, that is the polynomial+# 2*x^4+3*x^3+x^2+x+1 will be represented as [ [ 1, 1, 1, 3, 2 ], 0 ],+# and 5*x^10-2*x^8+x^6 as [ [ 1, 0, -2, 0, 5 ], 6 ]+#+KaratsubaPolynomialMultiplicationExtRep:=function( f, g )+local degf, degg, deg, n, halfn, nr, f1, f0, g1, g0, u, v, w, wuv, k, pos, pos1, val;+# Zero polynomial will be represented as [ [ ], 0 ]+# We took care that other representations of zero, for example [ [ 0, 0 ], 0 ] +# or [ [ 0, 0 ], 1 ], or [ [ 0 ], 1 ], can not occure, because we reduce+# the presentation after adding polynomials in PlusLaurentPolynomialsExtRep+# and subtracting them in MinusLaurentPolynomialsExtRep. Note that degree+# determination is also based on this feature.+if f[1]=[] or g[1]=[] then+ return [ [ ], 0 ];+fi;+if Length(f[1]) < KARATSUBA_CUTOFF and Length(g[1]) < KARATSUBA_CUTOFF then+ return [ PRODUCT_COEFFS_GENERIC_LISTS( f[1], Length(f[1]), g[1], Length(g[1]) ), f[2]+g[2] ];+fi;+# We determine degree from valuation and length of the coefficients list+degf := f[2]+Length(f[1])-1;+degg := g[2]+Length(g[1])-1;+deg := Maximum( degf, degg );+n:=1;+while n < deg do+ n:=n*2;+od;+# we can proceed immediately, since the case n=1 already caught by KARATSUBA_CUTOFF+halfn := n/2;+# developing the 1st polynomial+if degf >= halfn then+ k:=halfn-f[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(f[1])], k -> f[1][k] <> 0 );+ f1 := [ f[1]{[ pos1 .. Length(f[1])]}, val+pos1-pos ]; # EuclideanQuotient( f, b ) + # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-f[2] ], k -> f[1][halfn-f[2]-k+1] <> 0 ); + f0 := [ f[1]{[ 1 .. halfn-f[2]-pos1+1 ]}, f[2] ]; # EuclideanRemainder( f, b )+else+ f1 := [ [ ], 0 ];+ f0 := f;+fi;+# developing the 2nd polynomial+if degg >= halfn then+ k:=halfn-g[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(g[1])], k -> g[1][k] <> 0 );+ g1 := [ g[1]{[ pos1 .. Length(g[1])]}, val+pos1-pos ]; # EuclideanQuotient( g, b ) + # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-g[2] ], k -> g[1][halfn-g[2]-k+1] <> 0 ); + g0 := [ g[1]{[ 1 .. halfn-g[2]-pos1+1 ]}, g[2] ]; # EuclideanRemainder( g, b ) +else+ g1 := [ [ ], 0 ];+ g0 := g;+fi; +# three recursive calls+u := KaratsubaPolynomialMultiplicationExtRep(f1,g1);+v := KaratsubaPolynomialMultiplicationExtRep(f0,g0);+w := KaratsubaPolynomialMultiplicationExtRep(+ PlusLaurentPolynomialsExtRep(f1,f0),+ PlusLaurentPolynomialsExtRep(g1,g0) );+# composing the result+wuv := MinusLaurentPolynomialsExtRep( MinusLaurentPolynomialsExtRep(w,u), v );+wuv[2] := wuv[2] + halfn;+u[2] := u[2] + n;+return PlusLaurentPolynomialsExtRep( PlusLaurentPolynomialsExtRep(u,wuv), v );+# return u*(b^2) + (w-u-v)*b + v;+end;+++#############################################################################+#+# This is the top-level function that accepts polynomials in the natural+# presentation. The actual job is done by the recursively called function +# KaratsubaPolynomialMultiplicationExtRep. Nevertheless, we perform the +# first step in the top-level function instead of just passing the lists+# of coefficients to the KaratsubaPolynomialMultiplicationExtRep. This +# allows us to shorten the size of input, that maybe especially essential+# if KaratsubaPolynomialMultiplicationExtRep will be called as a web service.+#+KaratsubaPolynomialMultiplication:=function( f, g )+local deg, n, halfn, x, b, nr, fam, f1, f0, g1, g0, u, v, w, wuv,+ cf, cg, k, pos, pos1, val, result;+if IsZero(f) or IsZero(g) then + return Zero(f);+fi;+deg := Maximum( List( [f,g], DegreeOfLaurentPolynomial ) );+n:=1;+while n < deg do+ n:=n*2;+od;+if n=1 then+ return f*g;+else+ halfn := n/2;+ x := IndeterminateOfUnivariateRationalFunction( f );+ nr := IndeterminateNumberOfLaurentPolynomial(f); + fam := CoefficientsFamily( FamilyObj( f ) );+ # developing the 1st polynomial+ if DegreeOfLaurentPolynomial(f) >= halfn then+ cf := CoefficientsOfLaurentPolynomial( f );+ k:=halfn-cf[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(cf[1])], k -> cf[1][k] <> 0 );+ f1 := [ cf[1]{[ pos1 .. Length(cf[1])]}, val+pos1-pos ]; # EuclideanQuotient( f, b ) + # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-cf[2] ], k -> cf[1][halfn-cf[2]-k+1] <> 0 ); + f0 := [ cf[1]{[ 1 .. halfn-cf[2]-pos1+1 ]}, cf[2] ]; # EuclideanRemainder( f, b )+ else+ f1 := [ [ ], 0 ];+ f0 := CoefficientsOfLaurentPolynomial( f );+ fi;+ # developing the 2nd polynomial+ if DegreeOfLaurentPolynomial(g) >= halfn then+ cg := CoefficientsOfLaurentPolynomial( g );+ k:=halfn-cg[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(cg[1])], k -> cg[1][k] <> 0 );+ g1 := [ cg[1]{[ pos1 .. Length(cg[1])]}, val+pos1-pos ]; # EuclideanQuotient( g, b ) + # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-cg[2] ], k -> cg[1][halfn-cg[2]-k+1] <> 0 ); + g0 := [ cg[1]{[ 1 .. halfn-cg[2]-pos1+1 ]}, cg[2] ]; # EuclideanRemainder( g, b ) + else+ g1 := [ [ ], 0 ];+ g0 := CoefficientsOfLaurentPolynomial( g );+ fi; + # three recursive calls+ u := KaratsubaPolynomialMultiplicationExtRep(f1,g1);+ v := KaratsubaPolynomialMultiplicationExtRep(f0,g0);+ w := KaratsubaPolynomialMultiplicationExtRep(+ PlusLaurentPolynomialsExtRep(f1,f0),+ PlusLaurentPolynomialsExtRep(g1,g0) );+ # composing the result + wuv := MinusLaurentPolynomialsExtRep( MinusLaurentPolynomialsExtRep(w,u), v );+ wuv[2] := wuv[2] + halfn;+ u[2] := u[2] + n; + result := PlusLaurentPolynomialsExtRep( PlusLaurentPolynomialsExtRep(u,wuv), v );+ return LaurentPolynomialByCoefficients( fam, result[1], result[2], nr );+ # return u*(b^2) + (w-u-v)*b + v; +fi; +end;+++#############################################################################+#+# This is the web-service using version of KaratsubaPolynomialMultiplication+#+KaratsubaPolynomialMultiplicationWS:=function( f, g )+local deg, n, halfn, x, b, nr, fam, f1, f0, g1, g0, u, v, w, wuv,+ cf, cg, k, pos, pos1, val, wsresult, result;+if IsZero(f) or IsZero(g) then + return Zero(f);+fi;+deg := Maximum( List( [f,g], DegreeOfLaurentPolynomial ) );+n:=1;+while n < deg do+ n:=n*2;+od;+if n=1 then+ return f*g;+else+ halfn := n/2;+ x := IndeterminateOfUnivariateRationalFunction( f );+ nr := IndeterminateNumberOfLaurentPolynomial(f); + fam := CoefficientsFamily( FamilyObj( f ) );+ # developing the 1st polynomial+ if DegreeOfLaurentPolynomial(f) >= halfn then+ cf := CoefficientsOfLaurentPolynomial( f );+ k:=halfn-cf[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(cf[1])], k -> cf[1][k] <> 0 );+ f1 := [ cf[1]{[ pos1 .. Length(cf[1])]}, val+pos1-pos ]; # EuclideanQuotient( f, b )+ # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-cf[2] ], k -> cf[1][halfn-cf[2]-k+1] <> 0 ); + f0 := [ cf[1]{[ 1 .. halfn-cf[2]-pos1+1 ]}, cf[2] ]; # EuclideanRemainder( f, b )+ else+ f1 := [ [ ], 0 ];+ f0 := CoefficientsOfLaurentPolynomial( f );+ fi;+ # developing the 2nd polynomial+ if DegreeOfLaurentPolynomial(g) >= halfn then+ cg := CoefficientsOfLaurentPolynomial( g );+ k:=halfn-cg[2]+1;+ if k<1 then+ pos:=1;+ val:=1-k;+ else+ pos:=k; + val:=0; + fi; + # we remove initial zeroes in the quotient, if such exist+ pos1 := First([ pos .. Length(cg[1])], k -> cg[1][k] <> 0 );+ g1 := [ cg[1]{[ pos1 .. Length(cg[1])]}, val+pos1-pos ]; # EuclideanQuotient( g, b ) + # we remove trailing zeroes in the remainder, if such exist+ pos1 := First( [ 1 .. halfn-cg[2] ], k -> cg[1][halfn-cg[2]-k+1] <> 0 ); + g0 := [ cg[1]{[ 1 .. halfn-cg[2]-pos1+1 ]}, cg[2] ]; # EuclideanRemainder( g, b ) + else+ g1 := [ [ ], 0 ];+ g0 := CoefficientsOfLaurentPolynomial( g );+ fi; + # three recursive calls+ # u := KaratsubaPolynomialMultiplicationExtRep(f1,g1);+ # v := KaratsubaPolynomialMultiplicationExtRep(f0,g0);++ u := NewProcess( "WS_Karatsuba",[ String(f1), String(g1) ],"localhost", 26133); + v := NewProcess( "WS_Karatsuba",[ String(f0), String(g0) ],"localhost", 26134); + w := KaratsubaPolynomialMultiplicationExtRep(+ PlusLaurentPolynomialsExtRep(f1,f0),+ PlusLaurentPolynomialsExtRep(g1,g0) );+ + wsresult:=SynchronizeProcesses2( u,v );+ u := EvalString( wsresult[1].object );+ v := EvalString( wsresult[2].object );+ + # composing the result + wuv := MinusLaurentPolynomialsExtRep( MinusLaurentPolynomialsExtRep(w,u), v );+ wuv[2] := wuv[2] + halfn;+ u[2] := u[2] + n; + result := PlusLaurentPolynomialsExtRep( PlusLaurentPolynomialsExtRep(u,wuv), v );+ return LaurentPolynomialByCoefficients( fam, result[1], result[2], nr );+ # return u*(b^2) + (w-u-v)*b + v; +fi; +end;
+ misc/runit.g view
@@ -0,0 +1,62 @@+# Time-stamp: <Thu Jun 10 2010 22:08:10 Stardate: Stardate: [-28]3204.40 hwloidl>+#############################################################################+# Demo of using SymGrid-Par from within a GAP shell+#+# Setup (see USE document of the SymGrid-Par distribution):+# . launch several GAP servers from the commandline, eg.+# gap.sh sgp_server.g+# . launch the coordination server from the command line+# ./CoordinationServer_pp --verbose --debug -C 12321 +RTS -qp2+# . launch a gap.sh and run this script, step-by-step+# gap.sh+#############################################################################++# -----------------------------------------------------------------------------+# init+LoadPackage("scscp");+Read("sumEuler.g");+# -----------------------------------------------------------------------------+# connect to GAP server+EvaluateBySCSCP("WS_Phi", [87], "localhost", 26154);+EvaluateBySCSCP("WS_Fibonacci", [13], "localhost", 26154);+# -----------------------------------------------------------------------------+# connect to Coordination Server+EvaluateBySCSCP("CS_Phi", [87], "localhost", 12321);+# ./testClient 12321 fib 11+EvaluateBySCSCP("CS_Fib", [11], "localhost", 12321);+# standard test launching 2 instances of sumEuler+# ./testClient 12321 sumEulerClassic 13000 11000+EvaluateBySCSCP("CS_sumEulerClassicSCSCP", [13000, 11000], "localhost", 12321);+# ISSAC demo: std sumEuler example+# ./testClient 12321 sumEulerPar 8000 2000+EvaluateBySCSCP("CS_sumEulerPar", [8000, 2000], "localhost", 12321);+# different name for the same thing+EvaluateBySCSCP("CS_SumEuler", [8000, 2000], "localhost", 12321);+# ./testClient 12321 parMapFold WS_Phi WS_Plus 0 87 88 89+EvaluateBySCSCP("CS_parMapFold", ["WS_Phi", "WS_Plus", 0, [87, 88, 89]], "localhost", 12321);+# ./testClient 12321 parMapFold1 WS_Phi WS_Plus 87 88 89+EvaluateBySCSCP("CS_parMapFold1", ["WS_Phi", "WS_Plus", [87, 88, 89]], "localhost", 12321);+# ./testClient 12321 parMapFold WS_Res WS_Plus 0 92 93 94+EvaluateBySCSCP("CS_parMapFold", ["WS_Res", "WS_Plus", 0, [92, 93, 94]], "localhost", 12321);++# -----------------------------------------------------------------------------+# LOG+# --(ladybank02[46](3.2))-- gap.sh sgp_server.g +# Edit config.g to: SCSCPserverPort := 26154;+# --(ladybank02[46](3.2))-- gap.sh sgp_server.g +# --(ladybank02[56](3.2))-- ./CoordinationServer_pp --verbose --debug -C 12321 +RTS -qp2+# --(ladybank02[57](3.2))-- cd /scratch/hwloidl/txvi/SGP_v0.3.1/lib+# --(ladybank02[58](3.2))-- gap.sh+# gap> +# gap> LoadPackage("scscp");+# gap> Read("sumEuler.g");+# gap> EvaluateBySCSCP("Fib", [11], "localhost", 12321);+# #I Got back: object 89 with attributes +# [ [ "call_id", "coordinationServer:12321:6Imr75R8" ] ]+# rec( object := 89, +# attributes := [ [ "call_id", "coordinationServer:12321:6Imr75R8" ] ] )+# gap> EvaluateBySCSCP("sumEulerPar", [8000, 2000], "localhost", 12321);+# #I Got back: object 19455782 with attributes +# [ [ "call_id", "coordinationServer:12321:34xhmCty" ] ]+# rec( object := 19455782, +# attributes := [ [ "call_id", "coordinationServer:12321:34xhmCty" ] ] )
+ misc/sample-sgprc view
@@ -0,0 +1,2 @@+localhost 26153 GAP+localhost 26154 GAP
+ misc/sgp_admin.sh view
@@ -0,0 +1,161 @@+#!/bin/bash+# Time-stamp: <Wed Jun 23 2010 23:35:32 Stardate: Stardate: [-28]3269.49 hwloidl>+# $Id$+# -----------------------------------------------------------------------------+#+# Usage: sgp_admin <cmd> [options]+#+# Administrative commands for the SymGrid-Par installation.+#+# Commands:+# init ... run init script of the installation+# launch ... launch servers specified in a <file> argument (default: $SGPRC)+# kill ... kill running servers etc+#+# Options:+# -h ... help message+# -v ... be verbose+# -V ... show version+#+# -----------------------------------------------------------------------------++function pvm_start {+ echo "config" | pvm+}++function pvm_stop {+ echo "halt" | pvm+}++help=0+verbose=0+show_version=0+# default architecture+hwos=""++cs_port=12321 ++getopts "hvVa:" nam+while [ "$nam" != "?" ] ; do+ case $nam in+ h) help=1;;+ v) verbose=1;;+ V) show_version=1;;+ a) hwos="$OPTARG";;+ esac + getopts "hvVa:" nam+done++shift $[ $OPTIND - 1 ]++cmd="$1"++# if [ $OPTIND -lt 1 ]+# then echo "Usage: ./install.sh [options]"+# exit -1+# fi++# [ ( $show_version -eq 1 ) -o ( "$cmd" == "version" ) ]+if [ "$cmd" == "version" ]+ then + if [ -z "${SGP_ROOT}" ]+ then echo "SGP_ROOT undefined; do sgp_admin init to initialise SymGrid-Par"+ exit 1+ else echo "SymGrid-Par version $SGP_VERSION"+ exit 0+ fi +fi++# if [ ( $help -eq 1 ) -o ( "$cmd" == "help" ) ]+if [ "$cmd" == "help" ]+ then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \+ /^$/ { print n; \+ exit; } \+ { n++; }'`+ echo "`head -$no_of_lines $0`"+ exit +fi++if [ $verbose -eq 1 ]+ then echo "Command: $cmd"+ echo "Determining architecture: $hwos_str"+fi++INIT=`pwd`/sgp_init.sh++if [ "$cmd" == "init" ] + then source $INIT+ exit 0+fi++# for all other commands, we need SGP_ROOT etc+if [ -z "${SGP_ROOT}" ]+ then echo "SGP_ROOT undefined; do sgp_admin init to initialise SymGrid-Par"+ exit 1+fi++if [ -z "$cmd" ] + then echo "No command supplied"+ echo "Usage: sgp_admin <cmd> [options]"+ exit 1+fi++if [ "$cmd" == "launch" ]+ then ++file="$2"++if [ -z "$file" ] + then + if [ -z "${SGPRC}" ]+ then echo "SGPRC undefined"+ exit 1+ else sgprc="$SGPRC"+ fi+ else+ sgprc="$file"+ export SGPRC="$file"+ # echo "sgprc: $sgprc"+fi++ports="`cat $sgprc | awk '{ print $2 }'`"++# echo "Ports: $ports"+pushd ${SGP_ROOT}/lib++for p in $ports +do+ ${SGP_ROOT}/bin/gapd.sh -p $p -t ${SGP_ROOT}/lib/sgp_server.g+done++popd++exit 0++fi # launch++if [ "$cmd" == "start" ]+ then # for now we only launch the CoordinationServer+ CoordinationServer_pp --verbose ${cs_port} +RTS -qp${N} &++fi++if [ "$cmd" == "kill" ]+ then ++user="`whoami`"+# kill CoordinationServer+procs="`ps -u $user | fgrep ${user}=Coordin | awk '{ print $1 }' | sed ':a;N;\$!ba;s/\n/ /g' `"+if [ ! -z "$procs" ] + then kill -9 $procs+fi+# shut down pvm+pvm_stop+# kill running gap instances+procs="`ps -u $user | fgrep gap | awk '{ print $1 }' | sed ':a;N;\$!ba;s/\n/ /g' `"+if [ ! -z "$procs" ] + then kill -9 $procs+fi++fi # kill+
+ misc/sgp_client.g view
@@ -0,0 +1,139 @@+# +# -----------------------------------------------------------------------------+# basic packages needed++LoadPackage("scscp");+Read("sumEuler.g");++# -----------------------------------------------------------------------------+# global constants++SCSCPclientHost := "localhost";+SCSCPclientPort := 12321;++# -----------------------------------------------------------------------------+# some worker functions++QuillenSeriesByIdGroup := function( id )+local G, qs, latt, msl, ccs, ccs_repr, i, x, n;+G := SmallGroup( id );+latt := LatticeSubgroups(G);+msl := MinimalSupergroupsLattice(latt);+ccs := ConjugacyClassesSubgroups(latt);+ccs_repr := List(ccs, Representative);+qs := [];+for i in [ 1 .. LogInt( Size(G), PrimePGroup(G) ) ] do+ qs[i]:=0;+od;+for i in [ 1 .. Length(ccs_repr) ] do + if IsElementaryAbelian( ccs_repr[i] ) then+ if ForAll( msl[i], + x -> IsElementaryAbelian( ccs[x[1]][x[2]] ) = false ) then+ n := LogInt( Size(ccs_repr[i]), PrimePGroup(G) );+ qs[n] := qs[n] + 1;+ fi;+ fi;+od;+return [ id, qs ];+end;+++PointImages:=function( G, n )+local g;+return Set( List( GeneratorsOfGroup(G), g -> n^g ) );+end;++# -----------------------------------------------------------------------------+# Useful shortcuts++RandomPolynomial:=function(n)+local fam, f; +fam:=FamilyObj(1);+f:=LaurentPolynomialByCoefficients( fam, List([1..n],i->Random(Integers)), 0, 1 );+return f;+end;++RandomPolynomialAsString:=function(n)+return String(RandomPolynomial(n));+end;++Run1:=function( fct, args )+local res; +res:=EvaluateBySCSCP("CS_parProcesses1", [fct, args], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;+ +Run2:=function( fct1, fct2, args1, args2 )+local res; +res:=EvaluateBySCSCP("CS_parProcesses2", [fct1, fct2, args1, args2], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;+ +ParMap:=function( map_fct, list )+local res;+res:=EvaluateBySCSCP("CS_parMap", [ map_fct, list ], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;++ParMapFold:=function( map_fct, fold_fct, neutral, list )+local res;+res:=EvaluateBySCSCP("CS_parMapFold", [ map_fct, fold_fct, neutral, list ], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;++ParMapFold1:=function( map_fct, fold_fct, neutral, list )+local res;+res:=EvaluateBySCSCP("CS_parMapFold1", [ map_fct, fold_fct, neutral, list ], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;++ParZipWith:=function( zip_fct, list1, list2 )+local res;+res:=EvaluateBySCSCP("CS_parZipWith", [ zip_fct, list1, list2 ], SCSCPclientHost, SCSCPclientPort);+return res.object;+end;++# -----------------------------------------------------------------------------++ys:=[10,9,8,7,6,5,4,3,2,1]; +xs:=[1,2,3,4,5,6,7,8,9,10];+zs:=[87,88,89];+ +fam:=FamilyObj(1);+n:=20;+x_1:=Indeterminate(Rationals,"x_1");+x_2:=Indeterminate(Rationals,"x_2");+x_3:=Indeterminate(Rationals,"x_3");+x:=Indeterminate(Rationals,"x");+y:=Indeterminate(Rationals,"y");+z:=Indeterminate(Rationals,"z");++# ./testClient 12321 karaPar0 20+p1:=RandomPolynomial(n);+p2:=RandomPolynomial(n);+p3:=RandomPolynomial(n);+p4:=RandomPolynomial(n);+s1:=String(p1);+s2:=String(p2);+s3:=String(p3);+s4:=String(p4);+# EvaluateBySCSCP("CS_karatsubaParSCSCP", [s1,s2,s3,s4], SCSCPclientHost, SCSCPclientPort);++# GroebnerBasis (experimental)+p01:=x_1^2+x_2^2+x_3^2-1;+p02:=x_1^2+x_3^2-x_2;+p03:=x_1-x_2;+s01:=String(p01);+s02:=String(p02);+s03:=String(p03);+# EvaluateBySCSCP("CS_GroebnerBasis", [3, [s01,s02,s03]], SCSCPclientHost, SCSCPclientPort);+# l00:=[p01,p02,p03];+# GroebnerBasis(l00,MonomialLexOrdering());++q1:=RandomPolynomial(3);+q2:=RandomPolynomial(3);+q3:=RandomPolynomial(3);+qs1:=String(q1);+qs2:=String(q2);+qs3:=String(q3);+# EvaluateBySCSCP("CS_GroebnerBasis", [3, [qs1,qs2,qs3]], SCSCPclientHost, SCSCPclientPort);
+ misc/sgp_server.g view
@@ -0,0 +1,300 @@+#############################################################################+#+# This is the SCSCP server configuration file.+# The service provider can start the server just by the command +# $ gap myserver.g+#+# $Id: myserver.g 3120 2009-05-31 20:10:54Z alexk $+#+#############################################################################++#############################################################################+#+# Load necessary packages and read external files. +# Put here and other commands if needed.+#+#############################################################################++LogTo(); # to close log file if it was opened from .gaprc+LoadPackage("scscp");+LoadPackage("anupq");+LoadPackage("monoid");+Read("sumEuler.g");+Read("karatsuba.g");++#############################################################################+#+# Procedures and functions available for the SCSCP server+# (you can also install procedures contained in other files,+# including standard GAP procedures and functions) by adding+# appropriate calls to InstallSCSCPprocedure below.+#+#############################################################################+++#############################################################################+#+# IdGroupByGenerators( <list of permutations> )+# +# Returns the number of the group, generated by given permutations,+# in the GAP Small Groups Library.+# +IdGroupByGenerators:=function( permlist )+return IdGroup( Group( permlist ) );+end;+++#############################################################################+#+# IdGroup512ByCode( <pcgs code of the group> )+# +# The function accepts the integer number that is the code for pcgs of +# a group of order 512 and returns the number of this group in the+# GAP Small Groups library. It is assumed that the client will make sure+# that the code really corresponds to the group of order 512, since this+# can not be checked from the code itself.+#+IdGroup512ByCode:=function( code )+local G, F, H;+G := PcGroupCode( code, 512 );+F := PqStandardPresentation( G );+H := PcGroupFpGroup( F );+return IdStandardPresented512Group( H );+end;+++#############################################################################+#+# QuillenSeriesByIdGroup( [ ord, nr] )+# +# Let G:=SmallGroup( ord, nr ) be a p-group of order p^n. It was proved in +# [D.Quillen, The spectrum of an equivariant cohomology ring II, Ann. of +# Math., (2) 94 (1984), 573-602] that the number of conjugacy classes of +# maximal elementary abelian subgroups of given rank is determined by the +# group algebra KG. +# The function calculates this numbers for each possible rank and returns +# a list of the length n, where i-th element corresponds to the number of+# conjugacy classes of maximal elementary abelian subgroups of the rank i.+#+QuillenSeriesByIdGroup := function( id )+local G, qs, latt, msl, ccs, ccs_repr, i, x, n;+G := SmallGroup( id );+latt := LatticeSubgroups(G);+msl := MinimalSupergroupsLattice(latt);+ccs := ConjugacyClassesSubgroups(latt);+ccs_repr := List(ccs, Representative);+qs := [];+for i in [ 1 .. LogInt( Size(G), PrimePGroup(G) ) ] do+ qs[i]:=0;+od;+for i in [ 1 .. Length(ccs_repr) ] do + if IsElementaryAbelian( ccs_repr[i] ) then+ if ForAll( msl[i], + x -> IsElementaryAbelian( ccs[x[1]][x[2]] ) = false ) then+ n := LogInt( Size(ccs_repr[i]), PrimePGroup(G) );+ qs[n] := qs[n] + 1;+ fi;+ fi;+od;+return [ id, qs ];+end;+++PointImages:=function( G, n )+local g;+return Set( List( GeneratorsOfGroup(G), g -> n^g ) );+end;++Plus:=function(x,y)+return (x+y);+end;++#############################################################################+#+# Installation of procedures to make them available for WS +# (you can also install procedures contained in other files,+# including standard GAP procedures and functions)+#+#############################################################################++# Simple procedures for tests and demos+InstallSCSCPprocedure( "WS_Factorial", Factorial, "See ?Factorial in GAP", 1, 1 );+InstallSCSCPprocedure( "WS_Fibonacci", Fibonacci, "See ?Fibonacci in GAP", 1, 1 );+InstallSCSCPprocedure( "WS_Phi", Phi, "Euler's totient function, see ?Phi in GAP", 1, 1 );+InstallSCSCPprocedure( "WS_Plus", Plus, "Integer addition", 2, 2 );++InstallSCSCPprocedure( "WS_sumEulerClassic", sumEuler_classic, "see sumEuler.g", 1, 2);+InstallSCSCPprocedure( "WS_SumEulerRange", SumEulerRange, "see sumEuler.g", 1, 2);++# Group identification in the GAP small group library+InstallSCSCPprocedure( "GroupIdentificationService", IdGroupByGenerators, + "Accepts a list of permutations and returns IdGroup of the group they generate", 1, infinity );+InstallSCSCPprocedure( "WS_IdGroup", IdGroup, "See ?IdGroup in GAP", 1, 1 );+InstallSCSCPprocedure( "IdGroup512ByCode", IdGroup512ByCode, + "Identification of groups of order 512 using the ANUPQ package", 1, 1 );++# Important MIP (modular isomorphism problem for group algebras of finite p-group +# over the field of p elements) invariant+InstallSCSCPprocedure( "QuillenSeriesByIdGroup", QuillenSeriesByIdGroup, + "Quillen series of a finite p-group given by IdGroup (list of two integers)", 1, 1 );++# Service used to compute automorphism groups of transformation semigroups with+# the MONOID package, which requires the GRAPE package, and the latter requires +# the external program 'nauty' by Brendan D. McKay+InstallSCSCPprocedure( "WS_AutomorphismGroup", AutomorphismGroup, 1, 1 );+ +# Series of factorisation methods from the GAP package FactInt+InstallSCSCPprocedure("WS_FactorsTD", FactorsTD, + "FactorsTD from FactInt package, see ?FactorsTD in GAP", 1, 2 );+InstallSCSCPprocedure("WS_FactorsPminus1", FactorsPminus1, + "FactorsPminus1 from FactInt package, see ?FactorsPminus1 in GAP", 1, 4 );+InstallSCSCPprocedure("WS_FactorsPplus1", FactorsPplus1, + "FactorsPplus1 from FactInt package, see ?FactorsPplus1 in GAP", 1, 4 );+InstallSCSCPprocedure("WS_FactorsECM", FactorsECM, + "FactorsECM from FactInt package, see ?FactorsECM in GAP", 1, 5 );+InstallSCSCPprocedure("WS_FactorsCFRAC", FactorsCFRAC, + "FactorsCFRAC from FactInt package, see ?FactorsCFRAC in GAP", 1, 1 );+InstallSCSCPprocedure("WS_FactorsMPQS", FactorsMPQS, + "FactorsMPQS from FactInt package, see ?FactorsMPQS in GAP", 1, 1 );++InstallSCSCPprocedure("WS_ConwayPolynomial", ConwayPolynomial, "See ?ConwayPolynomial in GAP", 2, 2 );++InstallSCSCPprocedure( "PointImages", PointImages, + "1st argument is a permutation group G, 2nd is an integer n. Returns the set of images of n under generators of G", 2, 2 );++RandomPolynomial:=function(n)+local fam, f;+fam:=FamilyObj(1);+f:=LaurentPolynomialByCoefficients( fam, List([1..n],i->Random(Integers)), 0, 1 );+return f;+end;++InstallSCSCPprocedure("WS_RandomPolynomial", RandomPolynomial,+ "Calls LaurentPolynomialByCoefficients to generate a random polynomial", 0, 1 );++RandomPolynomialAsString:=function(n)+return String(RandomPolynomial(n));+end;++InstallSCSCPprocedure("WS_RandomPolynomialAsString", RandomPolynomialAsString,+ "Calls LaurentPolynomialByCoefficients to generate a random polynomial", 0, 1 );++KaratsubaPolynomialMultiplicationExtRepByString:=function(s1,s2)+return String( KaratsubaPolynomialMultiplicationExtRep( EvalString(s1), EvalString(s2) ) );+end;++InstallSCSCPprocedure("WS_KaratsubaStr", KaratsubaPolynomialMultiplicationExtRepByString, + "See Examples chapter in the SCSCP package manual", 2, 2 );++KaratsubaPolynomialMultiplicationExtRepByStringWithFixedIndeterminant:=function(s1,s2)+#fam:=FamilyObj(1);+# local x_1;+x_1:=Indeterminate(Rationals,"x_1");+return String( KaratsubaPolynomialMultiplication ( EvalString(s1), EvalString(s2) ) );+end;++InstallSCSCPprocedure("WS_KaratsubaStr_x", KaratsubaPolynomialMultiplicationExtRepByStringWithFixedIndeterminant, + "See Examples chapter in the SCSCP package manual", 2, 2 );+++Polynomial2String:=function(s)+return String(s);+end;++InstallSCSCPprocedure("WS_Polynomial2String", Polynomial2String,+ "String representation of the polynomial", 1, 1 );++InstallSCSCPprocedure("WS_Karatsuba", KaratsubaPolynomialMultiplicationBetter, + "See Examples chapter in the SCSCP package manual", 2, 2 );++ResultantWS:=function(s1,s2)+#fam:=FamilyObj(1);+# local x_1;+x_1:=Indeterminate(Rationals,"x_1");+return String( Resultant ( EvalString(s1), EvalString(s2), 1 ) );+end;++InstallSCSCPprocedure("WS_Resultant", ResultantWS,+ "See Sec 64.6 in GAP Manual", 2, 2 );++ResWS:=function(n)+local fam,f,g,z;+fam:=FamilyObj(1);+# n:=200;+f:=LaurentPolynomialByCoefficients( fam, List([1..n],i->Random(Integers)), 0, 1 );+g:=LaurentPolynomialByCoefficients( fam, List([1..n],i->Random(Integers)), 0, 1 );+z:=Resultant(f,g,1);+return z ; +end;++InstallSCSCPprocedure("WS_Res", ResWS,+ "See Sec 64.6 in GAP Manual", 1, 1 );++GroebnerBasisWS:=function(m,l)+local l1,n;+x_1:=Indeterminate(Rationals,"x_1");+x_2:=Indeterminate(Rationals,"x_2");+x_3:=Indeterminate(Rationals,"x_3");+n:=Length(l);+l1:=List([1..n],i->EvalString(l[i]));+return String (GroebnerBasis(l1,MonomialLexOrdering()));+end;++InstallSCSCPprocedure("WS_GroebnerBasis", GroebnerBasisWS,+ "GroebnerBasis; See Sec 64.17 in GAP Manual", 2, 2 );++ParMap:=function( list, map_fct )+local res;+res:=EvaluateBySCSCP("parMap", [ map_fct, list ], "localhost", 12321);+return res.object;+end;++ParMapFold:=function( list, neutral, map_fct, fold_fct )+local res;+res:=EvaluateBySCSCP("parMapFold", [ map_fct, fold_fct, neutral, list ], "localhost", 12321);+return res.object;+end;++InstallSCSCPprocedure("WS_FactorsInt", FactorsInt,+ "See Sec 14.3 in GAP Manual", 1, 1);++InstallSCSCPprocedure("WS_GcdInt", GcdInt,+ "See Sec 14.2 in GAP Manual", 2, 2 );+ +InstallSCSCPprocedure("WS_ChineseRem", ChineseRem,+ "See Sec 14.2 in GAP Manual", 2, 2 );++ +#############################################################################+#+# procedures for the UnitLib package for the parallel computation of the+# normalized unit group of a modular group algebra of a finite p-group+# from the GAP small groups library+#+if LoadPackage("unitlib") = true then+ if CompareVersionNumbers( GAPInfo.PackagesInfo.("unitlib")[1].Version, "3.0.0" ) then+ InstallSCSCPprocedure( "NormalizedUnitCFpower", NormalizedUnitCFpower );+ InstallSCSCPprocedure( "NormalizedUnitCFcommutator", NormalizedUnitCFcommutator );+ fi;+fi;+++#############################################################################+#+# procedure to test pickling/unpickling from the IO package for data encoding+# +IO_UnpickleStringAndPickleItBack:=function( picklestr )+return( IO_PickleToString( IO_UnpickleFromString( picklestr ) ) );+end;++InstallSCSCPprocedure( "IO_UnpickleStringAndPickleItBack", IO_UnpickleStringAndPickleItBack, + "To test how pickling format from IO package may be used for data transmitting (see ?IO_Pickle, ?IO_Unpickle)", 1, 1 );+++#############################################################################+#+# Finally, we start the SCSCP server. +#+#############################################################################++RunSCSCPserver( SCSCPserverAddress, SCSCPserverPort );
+ misc/sumEuler.g view
@@ -0,0 +1,87 @@+# Time-stamp: <Wed Jun 23 2010 21:32:17 Stardate: Stardate: [-28]3269.27 hwloidl>+#+# This version is used in SymGrid-Par v0.3 to run some simple tests+# -----------------------------------------------------------------------------++hcf_recursive:=function(x,y)+local m;+if y = 0 then + return x;+else+ m := x mod y;+ return hcf_recursive(y,m); +fi;+end; ++hcf_nonrecursive:=function(x,y)+local m;+m := x mod y;+while m <> 0 do+ x:=y; y:=m; m := x mod y; od; return y;+end; ++#############################################################################++relprime_recursive := function(x,y)+local m;+m:=hcf_recursive(x,y);+return m=1;+end;++relprime_nonrecursive := function(x,y)+local m;+m:=hcf_nonrecursive(x,y);+return m=1;+end;++relprime_classic := function(x,y)+local m;+m:=GcdInt(x,y);+return m=1;+end;++#############################################################################++euler_recursive := function(n)+local x;+x := Number(Filtered( [ 1..n ], x -> relprime_recursive(x,n) ) );+return x;+end;++euler_nonrecursive := function(n)+local x;+x := Number(Filtered( [ 1..n ], x -> relprime_nonrecursive(x,n) ) );+return x;+end;++euler_classic := function(n)+local x;+x := Number(Filtered( [ 1..n ], x -> relprime_classic(x,n) ) );+return x;+end;++#############################################################################++sumEuler_recursive:=function(n,m)+local result, x;+result:=Sum( [ n..m ], x -> euler_recursive(x) ); +return result;+end;++sumEuler_nonrecursive:=function(n,m)+local result, x;+result:=Sum( [ n..m ], x -> euler_nonrecursive(x) ); +return result;+end;++sumEuler_classic:=function(n,m)+local result, x;+result:=Sum( [ n..m ], x -> euler_classic(x) ); +return result;+end;++SumEulerRange:=function(n,m)+local result, x;+result:=Sum( [ n..m ], x -> euler_classic(x) ); +return result;+end;
+ src/Math/ComputerAlgebra/.Cash.hs.swp view
binary file changed (absent → 24576 bytes)
+ src/Math/ComputerAlgebra/Cash.hs view
@@ -0,0 +1,376 @@+{-# OPTIONS_GHC -cpp -XParallelListComp -XScopedTypeVariables #-}+-- Time-stamp: <Sat Jun 26 2010 03:18:15 Stardate: Stardate: [-28]3280.27 hwloidl>+--+-- cash: the computer algebra shell+-- This is the start of a ghci-based shell, using SCSCP calls for computer algebra+-- Compiling sequentially picks the (older) SCSCP_API.hs module.+-- Compiling in parallel picks the multi-threaded client ParSCSCP.hs module.+-----------------------------------------------------------------------------++-- are we talking directly to a GAP server or a Haskell-side Coordination server++module Math.ComputerAlgebra.Cash (server, initServer, call0, call1, call2, mkRand, mult, resultant, sumEuler_seq, euler, hcf, relprime, eulerWithSCSCP, sumEulerWithSCSCP+ ,sumEulerListSCSCP, sumEulerFromToWithSCSCP, doClient, toOMMatrix+ ,toOMList, fromOMList, a_sparse_9, b_sparse_9, polyFromString, bagInter, myGcd)+where++import Math.ComputerAlgebra.Cash.Date++#undef GAP_SERVER++#undef RUN_BUILTINS+#undef RUN_POLYS +#undef RUN_SUMEULER +#undef RUN_SUMEULER_PAR ++import List (delete)+import Network+import System+import System.Exit+import System.IO+import System.IO.Unsafe+-- import Time+import Control.Monad+import Control.Concurrent+import qualified Control.Exception as C++import Math.ComputerAlgebra.Cash.SGPTypes+import Math.ComputerAlgebra.Cash.SCSCP_API+import Math.ComputerAlgebra.Cash.HS_SCSCP+import Math.ComputerAlgebra.Cash.HS2SCSCP++-- examples how to use it+-- import SCSCP_Ex -- cut down version of SCSCP_Examples++#ifdef HAVE_SKELETONS+-- abstractions over patterns of parallel coordination+import Math.ComputerAlgebra.Cash.CA_Skeletons+#endif++-- These are services, known to the client from the start+import Math.ComputerAlgebra.Cash.BaseServices++#ifdef __PARALLEL_HASKELL__ +-- import EdenHelpers -- helper functions+-- import FoldDM+import Eden+#endif++-- import Poly+-- import TestPolys+-- import Karatsuba ++-- boilerplate setup, including pre-shared info+#if 0+main :: IO()+main = do+ args <- getArgs+ let portNum = if null args + then 12321+ else fromInteger (read (head args))+ doClient portNum+#endif++ngoq = initServer (server "localhost" (Just 12321))++-------------------------------------------------------+-- Util fcts (from ParSCSCP.hs)++call0 :: CAName -> OMObj +call0 name = unsafePerformIO (putStrLn $ "call0 of "++(show name)) `seq` + (callSCSCP name [])++call1 :: (OMData a, OMData b) =>+ CAName -> a -> b+call1 name x = fromOM (callSCSCP name [toOM x])++call2 :: (OMData a, OMData b, OMData c) =>+ CAName -> a -> b -> c+call2 name x y = fromOM (callSCSCP name [toOM x,toOM y])++mkRand n = callSCSCP scscp_CS_RandomPolynomialAsString ( map toOM [n] )++mult p1 p2 = callSCSCP scscp_CS_KaratsubaStr_x [p1, p2]++resultant p1OM_str p2OM_str = callSCSCP scscp_CS_Resultant ( map toOM [p1OM_str, p2OM_str] )++-------------------------------------------------------+-- purely Haskell side code++-- +fact :: Integer -> Integer+fact 0 = 1+fact n = n*(fact (n-1))++factAcc :: Integer -> Integer -> Integer+factAcc 0 acc = acc+factAcc n acc = factAcc (n-1) (n*acc)++sumEuler_seq :: Int -> Int+sumEuler_seq = sum . map euler . enumFromTo (1::Int)++---------------------------------------------------------------------------+-- main fct++euler :: Int -> Int+euler n = length (filter (relprime n) [1..(n-1)])++---------------------------------------------------------------------------+-- aux fcts+hcf :: Int -> Int -> Int+hcf x 0 = x+hcf x y = hcf y (rem x y)++relprime :: Int -> Int -> Bool+relprime x y = hcf x y == 1++-----------------------------------------------------------------------------++eulerWithSCSCP :: Int -> IO Int+eulerWithSCSCP n = do+ -- do the computation ...+ let fName = scscp_WS_Phi+ let args = map toOM [n]+ let resOM = callSCSCP fName args+ -- print the result+ let x = (fromOM resOM) :: Int+ return x++sumEulerWithSCSCP :: Int -> IO Int+sumEulerWithSCSCP n = do+ xs <- mapM eulerWithSCSCP [1..n]+ return (sum xs)++sumEulerListSCSCP :: [Int] -> IO Int+sumEulerListSCSCP ns = do+ xs <- mapM eulerWithSCSCP ns+ return (sum xs)+ +sumEulerFromToWithSCSCP :: Int -> Int -> IO Int+sumEulerFromToWithSCSCP m n = do+ xs <- mapM eulerWithSCSCP [m..n]+ return (sum xs)++-----------------------------------------------------------------------------++-- client for calling Euler totient function +-- currently only works with the purely Haskell dummyServer+-- GAP server works fine up to Phi function, but needs name scscp_WS_Phi +-- polynomials only supported for the Haskell server+doClient :: PortNumber -> IO ()+doClient portNum = do+ -- init ...+ putStrLn ("starting up client, opening port " ++ show portNum)+ initServer (server "localhost" (Just portNum))+#ifdef RUN_BUILTINS+ -------------------------------------------------------+ -- ask for available services+ putStrLn $ "Request for GetServiceDescr ..."+ let fName = Right GetServiceDescr+ let args = []+ let resOM = callSCSCP fName args+ putStrLn $ "Reply: "++(show resOM)+ -------------------------------------------------------+# ifdef GAP_SERVER+ -- ask for available services+ putStrLn $ "Request for GetTransientCD ..."+ let fName = Right GetTransientCD+ let args = map toOM ["scscp_transient_1"]+ let resOM = callSCSCP fName args+ putStrLn $ "Reply: "++(show resOM)+# endif+ -------------------------------------------------------+ -- ask for available services+ putStrLn $ "Request for GetAllowedHeads ..."+ let fName = Right GetAllowedHeads+ let args = []+ let resOM = callSCSCP fName args+ putStrLn $ "Reply: "++(show resOM)+ -------------------------------------------------------+# ifdef GAP_SERVER+ -- ask for available services+ putStrLn $ "Request for GetSignature ..."+ let fName = Right GetSignature + let args = map toOM ["scscp_transient_1", "WS_Phi"] -- HWL: BROKEN: wrong encoding of args; should be in OMS+ let resOM = callSCSCP fName args+ putStrLn $ "Reply: "++(show resOM)+# endif+#endif+ -------------------------------------------------------+ -- do the computation ...+ putStrLn $ "Running phi 12 ..."+ let fName = +# ifdef GAP_SERVER+ scscp_WS_Phi +# else+ scscp_CS_Phi+# endif+ let args = map toOM [12::Int]+ let resOM = callSCSCP fName args+ -- print the result+ let x = (fromOM resOM) :: Int+ putStrLn $ "Result: "++(show x)+#if 0+ putStrLn $ "Running factorial 5 ..."+ let fName = +# ifdef GAP_SERVER+ scscp_WS_Factorial+# else+ scscpFact+# endif+ let args = map toOM [5::Int]+ let resOM = callSCSCP fName args+ -- print the result+ let x = (fromOM resOM) :: Int+ putStrLn $ "Result: "++(show x)+#endif+ -- do the computation ...+#ifdef RUN_SUMEULER+ let n = 87+ putStrLn $ "Running sumEulerWithSCSCP "++(show n)++" ..."+ x <- sumEulerWithSCSCP n+ putStrLn $ "Result: "++(show x)+ putStrLn $ "Running sumEuler_seq "++(show n)++" ..."+ let y = sumEuler_seq n+ putStrLn $ "Result: "++(show y)+ putStrLn $ "Are the two results the same: "++(show (x==y))+#endif+ ----------------------------------------------------------------------------- + -- do the computation ...+ -- shutdown+ releaseServer++#ifdef __PARALLEL_HASKELL__+linearSolver :: [ Integer ] + -> [ [Integer] ] + -> [ Integer ]+ -> Arith +linearSolver ps ms vs+ = multHomImg (call2 scscp_WS_Mod) (call2 scscp_WS_Sol) (call2 scscp_WS_CRA) ps (toOMList ((toMatrix ms):[toOMList (map toNum vs)]))+++toNum :: Integer -> Arith+toNum x = Num x++toVector :: [Integer] -> Arith+toVector xs = MatrixRow (map (\z -> Num z) xs)++toMatrix :: [ [Integer] ] -> Arith+toMatrix (x:xs) = Matrix (map (\z -> MatrixRow (map toNum z)) (x:xs)) ++instance NFData (Arith) +instance Trans (Arith)+++parZipWith f primes list2 -- list3+ = newTasks+ where+ workerProcs = [process (zip [n,n..] . (worker f)) | n <- [1..noPe] ]++ (newReqs, newTasks) = (unzip . concat) (zipWith ( # ) workerProcs (distributeLists (primes, list2) requests)) -- (zipWith (#) workerProcs (distributeLists (list1, list2) requests))++ requests = (concat (replicate 2 [1..noPe])) ++ newReqs++ -- worker f [] = []+ -- worker :: (Trans a, Trans b) => (a -> b -> c) -> [(a,b)] -> [c]+ worker f [] = []+ worker f ((p, t2) : ts) = (f p t2) : worker f ts++ -- distributeLists :: ([t], [t]) -> [Int] -> [[(t,t)]]+ distributeLists tasks reqs = [ taskList reqs tasks n | n <- [ 1 .. noPe ] ]+ where+ taskList (r:rs) ( p:ps, t2:ts2 ) pe | pe == r = (p, t2) : (taskList rs (ps, ts2) pe)+ | otherwise = taskList rs (ps, ts2) pe+ taskList _ _ _ = []++ +multHomImg :: -- :: (Trans p, Trans c', Trans b') =>+ (Integer -> Arith -> Arith ) -> -- map input to homomorphic images+ (Integer -> Arith -> Arith) -> -- solve the problem in the hom. imgs.+ ([Integer] -> Arith -> Arith) -> -- combine the results to an overall result + [ Integer ] -> -- hom. imgs. to use. NOTE - will be supplied in a vector format!+ Arith -> -- input (matrix, vector)+ Arith -- result-}+multHomImg h f g ps x =+ res+ where+ xList = zipWith h ps (repeat x)+ resL = parZipWith f ps xList+ res = g ps (toOMMatrix resL) ++#endif++toOMMatrix xs = Matrix xs+toOMList xs = Math.ComputerAlgebra.Cash.SGPTypes.List xs++fromOMList (List xs) = xs+fromOMList (Matrix xs) = xs+fromOMList (MatrixRow xs) = xs++primes :: [Integer]+primes = sieve [2..]+ where+ sieve (p:xs) = p : sieve [x | x <- xs, x `mod` p /= 0] ++a_sparse_9 = + [ [ 763, 0, 0, 0, 633, 0, 0, 45, 0],+ [ 0, 1, 0, 0, 0, 0, 0, 0, 0],+ [ 0, 0, 3, 0, 0, 0, 0, 0, 42],+ [ 0, 125, 0, 1, 0, 0, 572, 0, 0],+ [ 27, 0, 35, 0, 1, 0, 0, 0, 11],+ [ 0, 0, 0, 0, 0, 1, 36, 0, 0],+ [ 0, 0, 26, 0, 0, 0, 1, 0, 46],+ [ 0, 19, 0, 0, 0, 0, 7, 1, 0],+ [ 57, 0, 0, 0, 2, 0, 0, 0, 92 ]]+b_sparse_9 = [0, 0, 0, 7, 0, 0, 0, 0, 11]++newtype Polynomial a = P OMObj++instance Show a => Show (Polynomial a) where+ show (P pOM) = fromOM pOM++instance Eq a => Eq (Polynomial a) where+ (P p1) == (P p2) = p1 == p2++instance Num (Arith {-Polynomial a-}) where+ (*) p1@(Polynomial _) p2@(Polynomial _) = call2 scscp_WS_ProdPoly p1 p2+ (+) p1@(Polynomial _) p2@(Polynomial _) = call2 scscp_WS_SumPoly p1 p2+ abs = error "abs on Polynomial not implemented"+ signum = error "signum on Polynomial not implemented"+ fromInteger n = fromOM $ toOM ("0*x_1+"++(show n))++polyFromString :: String -> Arith -- Polynomial Int+polyFromString = fromOM . toOM++instance OMData (Polynomial a) where+ toOM (P pOM) = pOM+ fromOM pOM = P pOM++class Factorisable a where+ factors :: a -> [a]++instance Factorisable Int where+ factors = call1 scscp_WS_FactorsInt++instance Factorisable Integer where+ factors = call1 scscp_WS_FactorsInt++instance Factorisable Arith where+ factors p1@(Polynomial _) = call1 scscp_WS_Factors p1++++bagInter :: (Eq a) => [a] -> [a] -> [a]+bagInter [] _ = []+bagInter (x:xs) ys | elem x ys = x:(bagInter xs (delete x ys))+ | otherwise = bagInter xs ys++myGcd :: (Num a, Factorisable a) => a -> a -> a+-- myGcd :: Arith -> Arith -> Arith+myGcd x y = let + xs = factors x+ ys = factors y+ zs = xs `bagInter` ys+ in+ if null zs then fromInteger 1 else foldl1 (*) zs+
+ src/Math/ComputerAlgebra/Cash/BaseServices.hs view
@@ -0,0 +1,129 @@+{-+Time-stamp: <Fri Jul 23 2010 21:38:00 Stardate: Stardate: [-28]3419.09 hwloidl>++This module defines basic services, provided via SCSCP interfaces, that should+be known to the coordination server from initialisation.++Naming scheme (it's just a scheme, for convenience, the CD should identify the service):+WS_ ... GAP server+HS_ ... Haskell server+CS_ ... Coordination server++See testClient.hs as an example of a client, testing the coordination server.+See CoordinationServer.hs, acting as a client to eg. GAP server.+-}++module Math.ComputerAlgebra.Cash.BaseServices where++import Math.ComputerAlgebra.Cash.SCSCP_API++-----------------------------------------------------------------------------+-- GAP services+scscp_WS_Plus = Left ("scscp_transient_1", "WS_Plus")+scscp_WS_Factorial = Left("scscp_transient_1", "WS_Factorial")+scscp_WS_Phi = Left ("scscp_transient_1", "WS_Phi") -- matches GAP server init+scscp_WS_Fibonacci = Left ("scscp_transient_1", "WS_Fibonacci") -- matches GAP server init+scscp_WS_FactorsInt = Left("scscp_transient_1", "WS_FactorsInt")+-- scscp_WS_Factors = Left("scscp_transient_1", "WS_Factors")+scscp_WS_Factors = Left("scscp_transient_1", "WS_FactorsStr") -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK+scscp_WS_FactorsStr = Left("scscp_transient_1", "WS_FactorsStr")+scscp_WS_GcdInt = Left("scscp_transient_1", "WS_GcdInt")+--scscp_WS_Bonzo = Left ("scscp_transient_1", "WS_Phi") -- matches GAP server init+scscp_WS_sumEulerClassic = Left("scscp_transient_1", "WS_sumEulerClassic")+scscp_WS_SumEulerRange = Left("scscp_transient_1", "WS_SumEulerRange")+scscp_WS_sumEulerList = Left("scscp_transient_1", "WS_sumEulerList")+scscp_WS_IdGroup = Left("scscp_transient_1", "WS_IdGroup")+scscp_WS_AutomorphismGroup = Left("scscp_transient_1", "WS_AutomorphismGroup")+-- ...+scscp_WS_RandomPolynomial = Left("scscp_transient_1", "WS_RandomPolynomial")+scscp_WS_RandomPolynomialAsString = Left("scscp_transient_1", "WS_RandomPolynomialAsString")+--scscp_WS_Karatsuba = Left("scscp_transient_1", "WS_Karatsuba")+scscp_WS_Polynomial2String = Left("scscp_transient_1", "WS_Polynomial2String")+scscp_WS_KaratsubaStr = Left("scscp_transient_1", "WS_KaratsubaStr")+scscp_WS_KaratsubaStr_x = Left("scscp_transient_1", "WS_KaratsubaStr_x")+scscp_WS_Karatsuba = Left ("scscp_transient_1","WS_Karatsuba")+scscp_WS_ProdPoly = Left("scscp_transient_1", "WS_ProdPoly")+scscp_WS_SumPoly = Left("scscp_transient_1", "WS_SumPoly")+--scscp_WS_KaratsubaGAPstr = Left ("scscp_transient_1","WS_Karatsuba") -- this uses strings as input, i.e. GAP specific+--scscp_WS_KaratsubaGAP = Left ("scscp_transient_1","HWL_Karatsuba")+--scscp_WS_Polynomial2String = Left ("scscp_transient_1", "HWL_Polynomial2String")+scscp_WS_Resultant = Left ("scscp_transient_1","WS_Resultant")+scscp_WS_Res = Left ("scscp_transient_1","WS_Res")+scscp_WS_GroebnerBasis = Left ("scscp_transient_1","WS_GroebnerBasis")++-----------------------------------------------------------------------------+-- Haskell services+scscp_HS_Phi = Left ("scscp_transient_2","euler")+scscp_HS_Fib = Left ("scscp_transient_2","fib")+scscp_HS_Factorial = Left ("scscp_transient_2","fact")+scscp_HS_FactorialAcc = Left ("scscp_transient_2","factAcc")+scscp_HS_Plus = Left ("scscp_transient_2","plus")+-- scscpSumEulerClassic = Left("scscp_transient_1", "WS_sumEulerClassic")+scscp_HS_ProductPoly = Left ("scscp_transient_2","productPoly")+scscp_HS_SumPoly = Left ("scscp_transient_2","sumPoly")+scscp_HS_DifferencePoly = Left ("scscp_transient_2","differencePoly")+scscp_HS_QuotientPoly = Left ("scscp_transient_2","quotientPoly")+scscp_HS_KaratsubaPoly = Left ("scscp_transient_2","karatsubaPoly")++-----------------------------------------------------------------------------+-- Coordination server+scscp_CS_Phi = Left ("scscp_transient_1", "CS_Phi")+scscp_CS_Fib = Left ("scscp_transient_1", "CS_Fib")+scscp_CS_Factorial = Left("scscp_transient_1", "CS_Factorial")+scscp_CS_GcdInt = Left("scscp_transient_1", "CS_GcdInt")+scscp_CS_GcdIntPar = Left("scscp_transient_1", "CS_GcdIntPar")+-- scscp_CS_GcdPoly = Left("scscp_transient_1", "CS_GcdPoly")+scscp_CS_GcdPolyPar = Left("scscp_transient_1", "CS_GcdPolyPar")+scscp_CS_SumEuler2 = Left("scscp_transient_1", "CS_sumEuler2") -- HACK: uses transient_1 to match with gap CLIENT+scscp_CS_SumEuler = Left("scscp_transient_1", "CS_SumEuler") -- HACK: uses transient_1 to match with gap CLIENT+scscp_CS_SumEulerPar = Left("scscp_transient_1", "CS_sumEulerPar") -- HACK: uses transient_1 to match with gap CLIENT+scscp_CS_SumEulerShuffle = Left ("scscp_transient_1","CS_sumEulerShuffleSCSCP") -- HACK: uses transient_1 to match with gap CLIENT+scscp_CS_RandomPolynomial = Left ("scscp_transient_1","CS_RandomPolynomial") -- pass through+scscp_CS_RandomPolynomialAsString = Left ("scscp_transient_1","CS_RandomPolynomialAsString") -- pass through+scscp_CS_Polynomial2String = Left("scscp_transient_1", "CS_Polynomial2String") -- pass through+scscp_CS_KaratsubaStr = Left("scscp_transient_1", "CS_KaratsubaStr") -- pass through+scscp_CS_KaratsubaStr_x = Left("scscp_transient_1", "CS_KaratsubaStr_x") -- pass through+scscp_CS_Karatsuba = Left ("scscp_transient_1","CS_Karatsuba") -- pass through+scscp_CS_KaratsubaPar = Left ("scscp_transient_1","CS_karatsubaParSCSCP")+scscp_CS_KaratsubaPar0 = Left ("scscp_transient_1","CS_karatsubaPar0SCSCP")+scscp_CS_ProdPoly = Left("scscp_transient_1", "CS_ProdPoly")+scscp_CS_SumPoly = Left("scscp_transient_1", "CS_SumPoly")+-- these are only passed through+scscp_CS_SumEulerClassic = Left ("scscp_transient_1","CS_sumEulerClassicSCSCP")+scscp_CS_Resultant = Left ("scscp_transient_1","CS_Resultant")+scscp_CS_Res = Left ("scscp_transient_1","CS_Res")+scscp_CS_Resultant2 = Left ("scscp_transient_1","CS_Resultant2")+scscp_CS_GroebnerBasis = Left ("scscp_transient_1","CS_GroebnerBasis")+-- skeletons+scscp_CS_ParProcesses1 = Left ("scscp_transient_1","CS_parProcesses1") -- run 1 givne services on given input lists+scscp_CS_ParProcesses2 = Left ("scscp_transient_1","CS_parProcesses2") -- run 2 given services on given input lists+scscp_CS_ParList = Left ("scscp_transient_1","CS_parList") -- parallel map+scscp_CS_ParMap = Left ("scscp_transient_1","CS_parMap") -- parallel map+scscp_CS_ParMap' = Left ("scscp_transient_1","CS_parMap'") -- parallel map+scscp_CS_ParMapFold = Left ("scscp_transient_1","CS_parMapFold") -- parallel fold-of-map+scscp_CS_ParMapFold1 = Left ("scscp_transient_1","CS_parMapFold1") -- parallel fold-of-map (non-empty list)+scscp_CS_ParZipWith = Left ("scscp_transient_1","CS_parZipWith") -- parallel zipWith+scscp_CS_Map = Left ("scscp_transient_1","CS_map") -- sequential map+scscp_CS_Map' = Left ("scscp_transient_1","CS_map'") -- sequential map+scscp_CS_MapFold = Left ("scscp_transient_1","CS_mapFold") -- sequential fold-of-map+scscp_CS_MapFold1 = Left ("scscp_transient_1","CS_mapFold1") -- sequential fold-of-map (non-empty list)+scscp_CS_ZipWith = Left ("scscp_transient_1","CS_zipWith") -- sequential zipWith++{-+-- some convenience short-cuts, good for interactive testing+s'prodPolyGB = scscpProductPoly+s'sumPolyGB = scscpSumPoly+s'diffPolyGB = scscpDifferencePoly+s'quotPolyGB = scscpQuotientPoly+s'karaGB = scscpKaratsuba++s'randPoly = scscpRandomPoly+s'poly2string = scscpPolynomial2String+s'kara = scscpKaratsubaGAP+s'kara' = scscpKaratsubaGAPstr+s'karaPar = scscpKaratsubaPar++s'sE = scscpSumEulerShuffle+s'sE2 = scscp_sumEuler2+s'sE' = scscpSumEulerClassic+-}
+ src/Math/ComputerAlgebra/Cash/CA_Skeletons.hs view
@@ -0,0 +1,302 @@+{-# OPTIONS_GHC -cpp -XParallelListComp #-}+{-# LANGUAGE ScopedTypeVariables #-} +-- Time-stamp: <Sat Jun 26 2010 03:18:45 Stardate: Stardate: [-28]3280.27 hwloidl>+--+-- Some skeletons for computer algebra computations, based on Eden skeletons.+----------------------------------------------------------------------------------++module Math.ComputerAlgebra.Cash.CA_Skeletons where++-- this contains the main SCSCP functionality+#ifdef __PARALLEL_HASKELL__ +import Math.ComputerAlgebra.Cash.ParSCSCP+#else+import Math.ComputerAlgebra.Cash.SCSCP_API+#endif+import Math.ComputerAlgebra.Cash.HS_SCSCP+import Math.ComputerAlgebra.Cash.HS2SCSCP++#ifdef __PARALLEL_HASKELL__ +import EdenHelpers -- helper functions+-- import FoldDM+import Eden+#endif++#ifdef __PARALLEL_HASKELL__ ++import System.IO.Unsafe++-----------------------------------------+-- special skeleton for SCSCP calls +-- +parMapSCSCP :: (Trans a, Trans b, OMData a, OMData b) =>+ CAName -> -- (a -> b) + [a] -> -- input, + [b] -- result+parMapSCSCP mapF = parmapfarm noPe (call1 mapF)++-- parmap in EdI +parMap' :: (Trans a, Trans b) => (Process a b) -> [a] -> [b]+parMap' proc xs = unsafePerformIO (mapM (instantiate proc) xs)++-- Eden process farm (np processes, each working on a whole sublist)+parmapfarm :: (Trans a, Trans b) => + Int -> (a -> b) -- worker process+ -> [a] -> [b] -- what to do+parmapfarm np f inputs = + shuffle (parMap' (process (map f)) (unshuffle np inputs))++-- potential optimisation: use explicit IO inside the processes, write+-- out chunks of pcalls instead of one by one. Or: make reply threads+-- work!++-- imported from FoldDM++fold_map_dm :: Trans b => Int -> (a->b) -> (b->b->b) -> b -> [a] -> b+fold_map_dm thr+ | noPe > thr = fmDM (noPe-1) + | otherwise = fmDM noPe+ +fmDM :: Trans b => Int -> (a->b) -> (b->b->b) -> b -> [a] -> b+fmDM np f comb cero tasks = foldl' comb cero (map deLift subresults) -- JB: remove Lift ...+ where subresults = [createProcess (worker pid np f comb cero tasks) () | pid <- [0,1..np-1]] `using` whnfspine+ -- JB: use createProcess instead of (***)++worker pid np f comb cero tasks = process (\() -> foldl' comb cero subresults)+ where subresults = map f (extract pid np tasks)+ extract i np ts = (unshuffle np ts) !! i++foldl' :: Trans a => (a->b->a) -> a -> [b] -> a+foldl' f a [] = a+foldl' f a (x:xs) = y `seq` foldl' f y xs+ where y = f a x ++foldl1' :: Trans a => (a->a->a) -> [a] -> a+foldl1' f [] = error "foldl1: empty list"+foldl1' f [x] = x+foldl1' f (x:(ys@(y:xs))) = foldl' f x ys++-- master worker... +-- import this from EdiWP.++-----------------------------------+-- fold only+-- +parFoldSCSCP_,+ parFoldSCSCP :: (Trans b, OMData b) =>+ CAName -> -- (b -> b -> b) + b -> [b] -> -- neutral, input, + b -- result+parFoldSCSCP foldF neutral inputs = scscpFoldl subRs+ where subRs = unsafePerformIO $ do + sequence [ instantiateAt i + (process scscpFoldl) + ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]+ scscpFoldl = foldl' (call2 foldF) neutral + -- non-optimised, moves accumulator around++parFoldSCSCP_ foldF neutral inputs + = scscpFoldlStart neutral subRs -- final stage with acc. reference as well+ where subRs = unsafePerformIO $ do + sequence [ instantiateAt i + (process (scscpFoldlStart neutral)) + ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]+ -- store intermediate results (acc.) inside the CA system+ scscpFoldlStart :: (Trans a, OMData a) => a -> [a] -> a+ scscpFoldlStart n [] = n+ scscpFoldlStart n xs = let nRef = call1R (Right StoreObj) n+ in nRef `seq` scscpFoldl nRef xs + scscpFoldl :: (OMData a, Trans a) => CARef -> [a] -> a+ scscpFoldl x [] = call1 (Right RetrieveObj) x+ scscpFoldl x (y:ys) = let x' = (call2R foldF x y)+ in x' `seq` scscpFoldl x' ys+++-- map and fold+parMapFoldSCSCP,+ parMapFoldSCSCP_ :: (Trans a, Trans b, OMData a, OMData b) =>+ CAName -> -- (a -> b) + CAName -> -- (b -> b -> b) + b -> [a] -> -- neutral, input, + b -- result+parMapFoldSCSCP mapF foldF neutral inputs = scscpFoldl neutral subRs+ where subRs = unsafePerformIO $ do + sequence [ instantiateAt i (process mapFoldSCSCP) ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]+ mapFoldSCSCP [] = neutral+ mapFoldSCSCP xs = scscpFoldl neutral (map (call1 mapF) xs)+ -- TODO: optimise this, by storing the map+ -- results inside the CA system and using+ -- a foldF :: [b] -> b which operates on+ -- whole lists.+-- scscpFoldl x [] = x+-- scscpFoldl x (y:ys) = let x' = (call2 foldF x y)+-- in x' `seq` scscpFoldl x' ys+ scscpFoldl = foldl' (call2 foldF)++-- map and fold+parMapFold1SCSCP :: (Trans a, Trans b, OMData a, OMData b) =>+ CAName -> -- (a -> b) + CAName -> -- (b -> b -> b) + [a] -> -- input, + b -- result+parMapFold1SCSCP mapF foldF inputs = scscpFoldl1 subRs+ where subRs = unsafePerformIO $ do + sequence [ instantiateAt i (process mapFold1SCSCP) ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]+ mapFold1SCSCP [] = error "mapFold1SCSCP: Empty list"+ mapFold1SCSCP xs = scscpFoldl1 (map (call1 mapF) xs)+ -- TODO: optimise this, by storing the map+ -- results inside the CA system and using+ -- a foldF :: [b] -> b which operates on+ -- whole lists.+-- scscpFoldl1 x [] = x+-- scscpFoldl1 x (y:ys) = let x' = (call2 foldF x y)+-- in x' `seq` scscpFoldl x' ys+ scscpFoldl1 = foldl1' (call2 foldF)+++-- map and fold+parMapFoldSCSCP_ mapF foldF neutral inputs + = scscpFoldl nRef subRs+ where nRef = call1R (Right StoreObj) neutral+ subRs = unsafePerformIO $ do + sequence [ instantiateAt i + (process (mapFoldSCSCP neutral)) ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]+ -- mapFoldSCSCP [] = neutral+ -- use foldF :: [b] -> b which operates on whole lists?+-- mapFoldSCSCP :: (OMData a, Trans a) => a -> [a] -> a+ mapFoldSCSCP n xs = scscpFoldlRef n (map (call1R mapF) xs)+ -- store intermediate results (acc.) inside the CA system+ scscpFoldlRef :: (OMData a) => a -> [CARef] -> a+ scscpFoldlRef n [] = n+ scscpFoldlRef n xs = let nRef = call1R (Right StoreObj) neutral+ in nRef `seq` scscpFoldlR nRef xs + -- arguments are stored as references (cookies):+ scscpFoldlR :: (OMData a) => CARef -> [CARef] -> a+ scscpFoldlR x [] = call1 (Right RetrieveObj) x+ scscpFoldlR x (y:ys) = let x' = (call2R foldF x y)+ in x' `seq` scscpFoldlR x' ys+ -- arguments are real data:+ scscpFoldl :: (OMData a, Trans a) => CARef -> [a] -> a+ scscpFoldl x [] = call1 (Right RetrieveObj) x+ scscpFoldl x (y:ys) = let x' = (call2R foldF x y)+ in x' `seq` scscpFoldl x' ys++-- zipWith -- UNTESTED!!!+parZipWithSCSCP :: (Trans a, Trans b, Trans c, OMData a, OMData b, OMData c) =>+ CAName -> -- (a -> b -> c) + [a] -> -- input list 1 + [b] -> -- input list 2 + [c] -- result list +parZipWithSCSCP f inputs1 inputs2 = shuffle subRs+ where subRs = unsafePerformIO $ do + sequence [ instantiateAt i (process (uncurry scscpBlock)) (ins1, ins2)+ | ins1 <- unshuffle noPe inputs1+ | ins2 <- unshuffle noPe inputs2+ | i <- [1..noPe] ]++ scscpBlock xs ys = zipWith (call2 f) xs ys++# else /* not parallel */++mapSCSCP :: (OMData a, OMData b) => -- (Trans a, Trans b, OMData a, OMData b) =>+ CAName -> -- (a -> b) + [a] -> -- input, + [b] -- result+mapSCSCP f = map (call1 f)+ -- where singleton x = [x]+foldSCSCP :: (OMData b) => -- (Trans b, OMData b) =>+ CAName -> -- (b -> b -> b) + b -> [b] -> -- neutral, input, + b -- result+foldSCSCP foldF neutral inputs = scscpFoldl inputs+ where {- subRs = unsafePerformIO $ do + sequence [ instantiateAt i + (process scscpFoldl) + ins + | ins <- unshuffle noPe inputs+ | i <- [1..noPe] ]-}+ scscpFoldl = foldl' (call2 foldF) neutral + -- non-optimised, moves accumulator around++-- HWL HACK+foldl' :: (a->b->a) -> a -> [b] -> a+foldl' f a [] = a+foldl' f a (x:xs) = y `seq` foldl' f y xs+ where y = f a x ++#endif++-- Eden boilerplate code... +unshuffle :: Int -> [a] -> [[a]]+unshuffle n xs = [takeEach n (drop i xs) | i <- [0..n-1]]+ where takeEach :: Int -> [a] -> [a]+ takeEach n [] = []+ takeEach n (x:xs) = x : takeEach n (drop (n-1) xs)+shuffle :: [[b]] -> [b]+-- shuffle = concat . transpose+ -- this impl. sequentially evaluation one input list after+ -- the other+-- for Eden we need a version, that produces the first outputs as fast+-- as possible, i. e. evaluates all input lists concurrently:+shuffle xxs+ | and (map null xxs) = []+ | otherwise = (mymaphead xxs) ++ ( shuffle (map mytail xxs))+ where mymaphead [] = []+ mymaphead ([]:xxs) = mymaphead xxs+ mymaphead ((x:xs):xxs) = x : mymaphead xxs+ mytail [] = []+ mytail xs = tail xs++{-+takeEach :: Int -> [a] -> [[a]]+takeEach n [] = []+takeEach n xs = let (start,rest) = splitAt n xs+ in start : takeEach n rest++-}++call2' :: (OMData a) =>+ CAName -> a -> a -> a+call2' name x y = fromOM (callSCSCP name [toOM x, toOM y])++-- sad, sequential versions of the skeletons+mapSCSCP :: (OMData a, OMData b, Trans b) => + CAName -> -- (a -> b) + [a] -> -- input, + [b] -- result+mapSCSCP mapF = map (call1 mapF)+++mapFoldSCSCP :: (OMData a, OMData b, Trans a, Trans b) => + CAName -> -- (a -> b) + CAName -> -- (b -> b -> b) + b -> [a] -> -- neutral, input, + b -- result+mapFoldSCSCP mapF foldF neutral inputs = foldl' (call2' foldF) neutral (map (call1 mapF) inputs)++mapFold1SCSCP :: (OMData a, OMData b, Trans b) => + CAName -> -- (a -> b) + CAName -> -- (b -> b -> b) + [a] -> -- input, + b -- result+mapFold1SCSCP mapF foldF inputs = foldl1' (call2' foldF) (map (call1 mapF) inputs)+++zipWithSCSCP :: (OMData a, OMData b, OMData c) => + CAName -> -- (a -> b -> c) + [a] -> -- input list 1 + [b] -> -- input list 2 + [c] -- result list +zipWithSCSCP f = zipWith (call2 f) ++
+ src/Math/ComputerAlgebra/Cash/Date.hs view
@@ -0,0 +1,10 @@+module Math.ComputerAlgebra.Cash.Date where+date = ", Wednesday 31 March 2010, 20:35"+sys_name = "SymGrid-Par"+release = " 0.3"+root = " /home/hwloidl/science/jra/systems/SymGrid-Par"+sgp_root = " "+hw_os = " i386-unknown-linux"+host_name = " localhost"+arch = " Linux localhost 2.6.29.6-desktop-2mnb #1 SMP Sun Aug 16 22:48:53 EDT 2009 x86_64 Intel(R) Core(TM)2 Duo CPU T9600 @ 2.80GHz GNU/Linux"+stardate = " Stardate: [-28]2848.87"
+ src/Math/ComputerAlgebra/Cash/HS2SCSCP.hs view
@@ -0,0 +1,214 @@+-- Time-stamp: <Thu Apr 01 2010 09:59:14 Stardate: Stardate: [-28]2851.66 hwloidl> +-- +-- Basic SCSCP operations such as readSCSCPMsg and writeSCSCPMsg. +-- Builds on HaXmL for realising OpenMath encoding. +----------------------------------------------------------------------------- + + +module Math.ComputerAlgebra.Cash.HS2SCSCP where + +import Math.ComputerAlgebra.Cash.SCSCP_DTD -- parser support +import Math.ComputerAlgebra.Cash.HS_SCSCP -- types + +import Text.XML.HaXml.Parse +import Text.XML.HaXml.Xml2Haskell +-- import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.Types +import Text.XML.HaXml.Verbatim +import Text.XML.HaXml.OneOfN +import Text.XML.HaXml.Pretty +import Text.PrettyPrint + +import Data.Maybe +import Data.Char + +-- debugging only +import Debug.Trace + +-- getContent :: Document -> Content +getTopElement (Document _ _ e _) = CElem e + +cleanUpStr xs = reverse (cleanUpStrAcc [] xs) + +cleanUpStrAcc acc ('\t':xs) = cleanUpStrAcc acc xs +cleanUpStrAcc acc ('\n':xs) = cleanUpStrAcc acc xs +cleanUpStrAcc acc (c:xs) = cleanUpStrAcc (c:acc) xs +cleanUpStrAcc acc [] = acc + +-- interface: read a message +readSCSCPMsg :: String -> SCSCPMsg +readSCSCPMsg str'= let str = cleanUpStr str' + parsed = xmlParse "<server output>" str + (interim,_) = fromElem [getTopElement parsed] + (OMOBJ _ (OMATTR atps oma)) = fromJust interim + -- processing attributes: + -- pairing on atps + pairs :: [(String,String)] + pairs = case atps of + Nothing -> [] + Just (OMATP xs) -> mkPairs xs + mkPairs [] = [] + mkPairs (OneOf2 (oms,OMSTR str):rest) + = ( oMSName oms,str):mkPairs rest + mkPairs (TwoOf2 (oms, OMI str):rest) + = (oMSName oms,str):mkPairs rest + -- always there (we hope so...) + callId = fromJust (lookup "call_id" pairs) -- HWL: WAS: "call_ID" + -- CATime and CAMem (aliased Int) not always there + maybeInt key = case lookup key pairs of + Nothing -> Nothing + Just s -> Just ((read s)::Int) + -- attributes for result and error: + t = maybeInt "info_runtime" + mem = maybeInt "info_memory" + -- attributes for call: + pct = maybeInt nMaxTime + pcmaxmem= maybeInt nMaxMem + pcminmem= maybeInt nMinMem + pcdebug = maybeInt nDebug + pcResult= Nothing -- for now + -- processing call/result/error data + (tipe,result) = case oma of + OMAOMS_OMR (x,OMR ref) + -> (oMSName x,toOM (CARef ref)) + OMAOMS_OME (x,OME oms (OMSTR err)) + -> (oMSName x, -- pass errors to HS land + error (oMSName oms ++ ": " ++ err)) + OMAOMS_EATALL (x,EAT (Elem n attrs c)) + -> (oMSName x, -- + OM n attrs (concatMap verbatim c)) + caError = case oma of + OMAOMS_OME (_,OME oms (OMSTR err)) + -> case oMSName oms of + -- scscp1 sez: + "error_memory" + -> CAMemExhausted + -- "error_CAS" in SCSCP-1.2.pdf + "error_system_specific" + -> CAMsg err + -- runtime exhausted? Spec.unclear + "error_runtime" + -> CATimeExhausted + -- callName = Left ("Why decode PCall?", + -- "I want to be a client anyway.") + -- The tricky thing here is, the OMA is parsed + -- by EATALL. We do not have the nice HaXml + -- structures and field names from above. + (callName,callRest) = + case oma of + OMAOMS_EATALL (x, EAT (Elem n attrs (oms:rest))) + -> (case fromElem [oms] of + (Just ok,_) -> let cd = oMSCd ok + in if cd == "scscp2" + -- all special op.s + -- are defined there + then Right + (decodeOp + (oMSName ok)) + else Left (cd,oMSName ok) + other -> Left ("sys error", + "cannot extract call name: found\n"++(show oma)) + , -- FIXME: debug code only, all strings + map contentToOM rest ) + other -> (Left ("sys error","invalid PCall format") + , []) + in -- trace ("!! raw string read is: \n"++str) $ + case tipe of + "procedure_completed" + -> PResult result callId t mem + "procedure_terminated" + -> PTerminated callId caError t mem + "procedure_call" + -> PCall callId callName callRest + (PCOpts pcResult pct pcminmem + pcmaxmem pcdebug) + -- error ("Why should I decode PCall?" ++ + -- " I am a client, not a server!") + other -> error "unexpected SCSCP message type" + +scscpPrefix = "<OMOBJ><OMATTR><OMATP>" +-- then the options. we assume call_ID to be always present. +scscpInfix = "</OMATP><OMA>" +-- then the OMS indicating the type, then the included data, which can +-- be OMA, OME, OMR, or any other result type +scscpSuffix = "</OMA></OMATTR></OMOBJ>" + +----------------------------------------------------------------------------- +-- Main routine + +-- construct OM encoding of a message +writeSCSCPMsg :: SCSCPMsg -> String -- XML +writeSCSCPMsg (PCall id name args opts) + = scscpPrefix + ++ writeOpts id opts -- see HS_SCSCP + ++ scscpInfix + ++ "<OMS cd=\"scscp1\" name=\"procedure_call\" />" + ++ "<OMA><OMS cd=" ++ show cd + ++ " name=" ++ show op ++ " />" + ++ (if null ref + then concatMap writeOMObj args + else ref) + ++ "</OMA>" + ++ scscpSuffix + where (cd,op,ref) = case name of + Left (cd,n) -> (cd,n,"") +-- Right UnbindObj +-- -> ("scscp2","unbind", +-- writeOMObj (toOM r)) +-- Right RetrieveObj +-- -> ("scscp2","retrieve", +-- writeOMObj (toOM r)) + Right special -> ("scscp2", encodeOp special, bonzo special) -- HWL: CHECK: whether scscp1 or scscp2 + -- decode: see HS_SCSCP + bonzo GetSignature | length args < 2 = error $ "bonzo: length of arguments to GetSignature too short; should be 2 but is" ++(show (length args)) + | otherwise = "<OMS cd=\""++(getContentFromOMObj (args!!0))++"\" name=\"" ++ (getContentFromOMObj (args!!1)) ++ "\"/>" -- HWL: HACK: encode arguments to GetSignature in an OMS (BROKEN) + bonzo _ = "" + + getContentFromOMObj (OM tag attList []) = error "getContentFromOMObj: empty content in OMObj" + getContentFromOMObj (OM tag attList nonemptyContent) = nonemptyContent + +writeSCSCPMsg (PTerminated id err t mem) + = scscpPrefix + ++ writeInfos id t mem + ++ scscpInfix + ++ "<OMS cd=\"scscp1\" name=\"procedure_terminated\" />" + ++ "<OME><OMS cd=\"scscp1\" name=" + ++ show (errTypeName err) + ++ " /><OMSTR>" ++ errText err ++ "</OMSTR>" + ++ "</OME>" + ++ scscpSuffix +writeSCSCPMsg (PResult res id t mem) + = scscpPrefix + ++ writeInfos id t mem + ++ scscpInfix + ++ "<OMS cd=\"scscp1\" name=\"procedure_completed\" />" + ++ writeOMObj res + ++ scscpSuffix + +-- my own pretty-printer, simple indentation only +indentXml :: String -> String +-- for now hand-rolled: separate each tag in a new line +-- entry, when starting like xml should: +indentXml ('<':rest) = '<':indent 1 rest + where indent :: Int -> String -> String + -- end + indent lvl "" = "" + -- tag immediately closed: + indent lvl ('/':'>':rest) = "/>" + ++ indent (lvl-1) rest + -- closing tag: + indent lvl ('<':'/':rest) = '\n':replicate (lvl-1) ' ' + ++ "</" ++ + endTag (lvl-1) rest + -- opening tag: + indent lvl ('<':rest) = '\n':replicate lvl ' ' + ++ '<':indent (lvl+1) rest + -- no tag delimiter + indent lvl(s:rest) = s:indent lvl rest + endTag l ('>':rest) = '>':indent l rest + endTag l (s:rest) = s:endTag l rest + endTag l [] = "" -- should not happen, though +indentXml other = other -- in fact, not xml +-- later: try using HaXml. Seems to introduce some overhead, though. +-- indentXml = render . document +
+ src/Math/ComputerAlgebra/Cash/HS_SCSCP.lhs view
@@ -0,0 +1,1123 @@+% some latex stuff for typesetting literate code...++% command to wrap around code which should not show+\newcommand{\texignore}[1]{}++% uniform size for all code flavours+\newcommand{\codesize}{\scriptsize}++% code highlighting commands (in text and in own block)+\newcommand{\cd}[1]{{{\codesize \tt{#1}}}}++% code environments, completely verbatim (fancyvrb):+\renewcommand{\FancyVerbFormatLine}[1]{~~~#1}+\DefineVerbatimEnvironment{code}{Verbatim}{fontsize=\codesize, frame=lines,+ label=\textit{compiled code}}+\DefineVerbatimEnvironment{icode}{Verbatim}{fontsize=\codesize, frame=lines,+ label=\textit{ignored code}}+\DefineVerbatimEnvironment{xcode}{Verbatim}{fontsize=\codesize, frame=lines}++\texignore{% i.e., do not print this...+\begin{code}+{-# OPTIONS_GHC -cpp -XOverlappingInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE IncoherentInstances #-} +module Math.ComputerAlgebra.Cash.HS_SCSCP where+\end{code}+}++\author{Jost Berthold, Hans-Wolfgang Loidl, Chris Brown University of St.Andrews (\{hwloidl,jb, chrisb\}@cs.st-andrews.ac.uk)}++\hwlcomment{This documentation is incomplete and needs update before the release!!}++This document was first created to describe first (top-down) +implementation ideas for+SCSCP in Haskell (client only). Meanwhile, changes have been made +throughout, and the module now provides types and conversions from+SCSCP-XML to Haskell and vice-versa.+We continue to collect the basic ideas and notes here.++SCSCP\cite{SCSCP-1.2} is a protocol+for interaction between computer-algebra systems, following the+OpenMath standard and developed in the SCIEnce EU project. +\marginpar{\jbcomment{updated to SCSCP-1.3}}+Basis of+our design is the version 1.2 of the protocol specification.+The content dictionaries (CD) for SCSCP are scscp1 and scscp2.+% and +% they slightly differ from the SCSCP-1.2 description. When different,+% we follow the scscp CD definition of keywords, and the +% SCSCP-1.2 spec. for message formats.++For any terminology, pls. refer to the aforementioned specification+and to the content dictionaries.++\section*{Implementing SCSCP in Haskell}++\subsection*{Features summary}++ The goal of the implementation is to send computation requests from+ a Haskell program to a CA system, and to receive the answers for+ further processing.++ Furthermore, the module provides features for starting and stopping+ its respective communication partners, namely SCSCP servers linked+ to CA systems.++ Implementing such an SCSCP client lays the ground for a more+ long-term goal: implementing a coordination server to use several CA+ systems in parallel. Such a server should be able to answer client+ requests, and otherwise coordinate computations which we provide as+ skeletons (and define an according \cd{symgrid-par} content+ dictionary).++\subsection*{Limitations}+\begin{itemize}++\item We want to implement an interface for the SCSCP usage via+ sockets, thus not using a web service.+\item Most likely, not all possible functionality of a client will be+ implemented. For the implemented features, see the subsequent+ description.+\item Where possible, potentially large computation data should not be+ accessed inside the calling Haskell program. Haskell serves as a+ coordination layer. Thus, SCSCP messages will only be decomposed to+ a degree which allows to coordinate the respective computation, and+ included computation data otherwise passed on as opaque objects.+\item we do not implement the binary OpenMath format in this version,+ but restrict ourselves to the XML variant.+\end{itemize}++\newpage++This is where the code starts.++Some imports (technical...):+\begin{code}++import Text.XML.HaXml.Types++-- and for parsing in OMObj:+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Verbatim++import Data.Char+import Data.Maybe+import Data.List++-- import the standard types for CA. +-- currently these are manually defined, should we move+-- towards the Numeric Prelude?+import Math.ComputerAlgebra.Cash.SGPTypes++import Debug.Trace++import Control.Monad -- for maybe monad+import Control.DeepSeq (NFData(..))+import Control.Parallel.Strategies hiding (NFData(..)) -- for NFData OMObj+#ifdef __PARALLEL_HASKELL__+import Eden(Trans)+#endif+\end{code}++\subsection*{SCSCP data objects}++First of all, SCSCP data (in OpenMath XML) needs to be sent and+received, thus stored inside Haskell, and sometimes also accessed from+Haskell code. While we want to avoid it, still we need to extract+basic types such as \cd{Bool}, \cd{Int}, \cd{Integer}, and+\cd{String}.++We store OpenMath objects as their enclosing tag, including potential+attributes, and the contents as verbatim. In this manner, we can+compose the XML from it easily, even without deeper XML knowledge.+For simple types (in type class OMData), we generate the OpenMath+representation ourselves, and can read it out just as easily.++\begin{code}+-- data objects, opaque if at all possible+type Tag = String+data OMObj = OM + Tag -- as name suggests+ [Attribute] -- attribute list+ String -- embedded XML+ deriving (Eq,Show)++instance NFData OMObj where+ rnf (OM tag attrs content) = rnf (tag,attrs,content)+-- instance NFData Attribute... but Attribute is an alias+-- These guys need to be defined for it.+instance NFData AttValue where + rnf (AttValue vals) = rnf vals +instance NFData Reference where+ rnf (RefEntity ref) = rnf ref+ rnf (RefChar n) = rnf n++#ifdef __PARALLEL_HASKELL__+instance Trans OMObj+#endif++-- to parse in an OMObj, we use the HaXml parser+-- failure is passed to the caller by the contents+parseOM :: String -> OMObj+parseOM input = case xmlParse' "parseOM-internal" input of + Left errmsg -> let err = error ("cannot parse this OMObj: " + ++ take 100 input + ++ "...:\n" ++ errmsg)+ in OM err err err+ Right (Document _ _ (Elem tag atts cs) _) + -> OM tag atts (concatMap verbatim cs)++-- without parsing, directly XML elements (HaXml type) to OMObj+elemToOM :: Element -> OMObj+elemToOM (Elem tag atts cs) = OM tag atts (concatMap verbatim cs)+contentToOM :: Content -> OMObj+contentToOM (CElem (Elem tag atts cs)) + = OM tag atts (concatMap verbatim cs)+contentToOM (CString _ t) = toOM t -- encode it as a string+contentToOM (CMisc x) = error "contentToOM: unexpected content" ++-- converting back OMObj as XML. We do it directly, don't know what+-- HaXML would format for us+writeOMObj :: OMObj -> String+writeOMObj (OM tag attList []) + | tag == "OMSTR" = "<OMSTR></OMSTR>" -- workaround needed in GAP SCSCP+ | otherwise = '<':tag ++ ' ':writeAttributes attList ++ "/>"+writeOMObj (OM tag attList nonemptyContent)+ = '<':tag ++ ' ':writeAttributes attList + ++ ' ':'>':nonemptyContent ++ '<':'/':tag ++ ">"++-- ... but we can convert it back to a HaXml type as well, +-- ignoring that the content might contain tags:+objToHaXml :: OMObj -> Content+objToHaXml (OM tag attList content) + = CElem (Elem tag attList [CString True content])++writeAttributes :: [Attribute] -> String+writeAttributes = unwords . map showAttribute++showAttribute :: Attribute -> String+showAttribute (name, val) + = name ++ "=" ++ show val++-- Attribute is an alias, thus not instance of Show... +-- These guys need to be defined for it.+instance Show AttValue where + show (AttValue vals) = "\"" ++ concatValStrings vals ++ "\""++concatValStrings :: [Either String Reference] -> String+concatValStrings [] = ""+concatValStrings ((Left s):rest) = s ++ concatValStrings rest+concatValStrings ((Right ref):rest) = show ref ++ concatValStrings rest++instance Show Reference where + show (RefEntity ref) = '&':ref ++ ";"+-- show (RefChar n)) = "\"&#" ++ show n ++ ";\""+ show (RefChar n) = "&#x" ++ hex n ++ ";"++-- +hex :: Int -> String+hex n | n < 0 = hex (n `mod` 256) -- HACK+ | n < 16 = c:""+ | otherwise = hex rest ++ digits!!last : ""+ where rest = n `div` 16+ last = n `mod` 16+ c = digits!!n+ digits= "0123456789ABCDEF"+\end{code}++We want to pass around OM objects inside Haskell, but +not inspect them (see above). Certain simple Haskell +types need to be convertible to OMObj (which we do +straight-forward by hand,), we define a type class +and instances for the conversion here.++\begin{code}++-- A type class for Haskell data types which can be embedded in an+-- SCSCP message.+class OMData a where + toOM :: a -> OMObj+ fromOM :: OMObj -> a++instance OMData OMObj where + toOM = id+ fromOM = id++-- <OMS cd="logic1" name="true"/>+instance OMData Bool where+ toOM b = OM "OMS" atts "" + where atts :: [Attribute]+ atts = [("cd" ,AttValue [Left "logic1"]),+ ("name",AttValue [Left val] ) ]+ val = if b then "true" else "false"+ fromOM (OM "OMS" attribs "" ) + | (cd `elem` attribs) + && isJust attribute = decode val+ where attribute = lookup "name" attribs + AttValue ((Left val):_) = fromJust attribute+ cd = ("cd",(AttValue [Left "logic1"]))+ decode "true" = True+ decode "false" = False+ fromOM other = error ("cannot read Boolean from " ++ show other)++instance OMData Int where+ toOM i = OM "OMI" [] (show i)+ fromOM (OM "OMI" [] num) = read num+ fromOM other = error ("cannot read Int from " ++ show other)+instance OMData Integer where+ toOM i = OM "OMI" [] (show i)+ fromOM (OM "OMI" [] num) = read num+ fromOM other = error ("cannot read Integer from " ++ show other)++instance OMData String where+ toOM s = OM "OMSTR" [] (encodeXML s)+ fromOM (OM "OMSTR" [] txt) = txt+ fromOM other = error ("cannot treat " ++ show other ++ " as String")++{-instance OMData MatrixRow where+ toOM (MatrixRow ariths) = res+ where res = OM "OMA" [] (concat (map writeOMObj ([OM "OMS" [("cd", AttValue [Left "linalg2"]),+ ("name", AttValue [Left "matrixrow"])] "", toOM ariths])))++ fromOM (OM "OMA" [] listXML) =+ case parsed of+ Left msg -> passError msg+ Right (Document _ _ (Elem oma [] ((CElem lSym):elems)) _)+ -> scrut lSym elems+ where -- use xmlParse' to deconstruct+ scrut lSym elems+ | isMatrixRowSym lSym = (MatrixRow (mkF elems))+++ | otherwise = passError "Not a MatrixRow element"+ +++ parsed = xmlParse' "list-parse" + ("<OMA>" ++ trim listXML ++ "</OMA>")+ -- String trimming (remove white). definition below.+ mkF e = (map (fromOM . parseOM) . + filter (not . all isSpace) . -- rule out \n+ map verbatim) e+ passError msg = error ("cannot parse as a matrixRow:"+ ++ take 100 listXML + ++ "..: " ++ msg)+ fromOM other = error ("cannot read matrixRow from " ++ show other) -}+++-- added by Chris Brown 9 Sept 2010+-- convert to numeric prelude?+instance OMData Arith where+ toOM (Polynomial s) = toOM s++ toOM (Matrix rows) = OM "OMA" [] (concat (matrixOMS : map (writeOMObj . toOM) rows))++ toOM (List xs) = OM "OMA" [] (concat (listOMS : map (writeOMObj . toOM) xs))++ toOM (MatrixRow ariths) = OM "OMA" [] (concat (matrixRowOMS : map (writeOMObj . toOM) ariths)) ++ toOM (Num x) = OM "OMI" [] (show x)+ toOM (Mul x y) = OM "OMA" [] (concat (map writeOMObj ([OM "OMS" [("cd", AttValue [Left "arith1"]),+ ("name", AttValue [Left "times"])] "", toOM x, toOM y])))++ toOM (Power x y) = OM "OMA" [] (concat (map writeOMObj ([OM "OMS" [("cd", AttValue [Left "arith1"]),+ ("name", AttValue [Left "power"])] "", toOM x, toOM y])))+ + toOM (Rational ariths) = OM "OMA" [] (concat (rationalOMS : map (writeOMObj . toOM) ariths)) ++ -- fromOM (OM "OMS" _ _) =error "herhehrerher!"+ fromOM (OM "OMSTR" [] txt) = Polynomial txt+ fromOM (OM "OMI" [] num) = Num (read num)+ fromOM (OM "OMA" [] listXML) =+ case parsed of+ Left msg -> passError msg+ Right (Document _ _ (Elem oma [] ((CElem lSym):elems)) _)+ -> scrut lSym elems+ where -- use xmlParse' to deconstruct+ scrut lSym elems+ -- | isEmptySym lSym = Empty+ | isArithMulSym lSym = (Mul (head (mkF [head elems])) (head (mkF [head (tail elems)])))+ | isArithPowerSym lSym =(Power (head (mkF [head elems])) (head (mkF [head (tail elems)])))+ | isMatrixSym lSym = (Matrix (mkF elems))+ | isMatrixRowSym lSym = (MatrixRow (mkF elems))+ | isRationalSym lSym = (Rational (mkF elems))+ | isListSym lSym = (MatrixRow (mkF elems))+ | otherwise = passError "Not an Arithmetic element"+ +++ parsed = xmlParse' "list-parse" + ("<OMA>" ++ trim listXML ++ "</OMA>")+ -- String trimming (remove white). definition below.+ mkF e = (map (fromOM . parseOM) . + filter (not . all isSpace) . -- rule out \n+ map verbatim) e+ passError msg = error ("cannot parse as an arith:"+ ++ take 100 listXML + ++ "..: " ++ msg)+ fromOM other = error ("cannot read Int from " ++ show other)++++instance OMData FiniteField where+ toOM (PrimEl x) = res + where res = OM "OMA" [] ((concat (map writeOMObj [OM "OMS" att1 "", toOM x])))+ att1 :: [Attribute]+ att1 = [("cd", AttValue [Left "finfield1"]),+ ("name", AttValue [Left "primitive_element"] )]+ fromOM (OM "OMA" [] listXML) =+ case parsed of + Left msg -> passError msg+ Right (Document _ _ (Elem oma [] ((CElem lSym):elems)) _)+ -> if isFiniteSym lSym+ then (PrimEl (head (mkFinite elems)))+ else passError "Not a finite field"+ where -- use xmlParse' to deconstruct+ parsed = xmlParse' "list-parse" + ("<OMA>" ++ trim listXML ++ "</OMA>")+ -- String trimming (remove white). definition below.+ mkFinite = map (fromOM . parseOM) . + filter (not . all isSpace) . -- rule out \n+ map verbatim + passError msg = error ("cannot parse as a list:"+ ++ take 100 listXML + ++ "..: " ++ msg)+encodeXML :: String -> String+encodeXML "" = ""+encodeXML ('&':s) = "&" ++ encodeXML s+encodeXML ('<':s) = "<" ++ encodeXML s+encodeXML ('>':s) = ">" ++ encodeXML s+encodeXML (c:s) | isPrint c = c:encodeXML s+ | otherwise = "&#" ++ show (ord c) ++ ';':encodeXML s+++-- todo: a list instance would perhaps be very handy. +-- Problems:+-- 1. we need to decompose/chop the string at its element delimiters+-- 2. (more severe) we could get back a weird list which leads to a+-- type error (list with holes, different types).+-- 3. we want a separate instance for String. So we add the flag+-- -XOverlappingInstances -fallow-incoherent-instances++-- added Chris Brown 11 August 2010+-- added provision to allows marshalling of matrices from GAP+-- a matrix is a [[a]] component++instance OMData a => OMData [a] where + toOM xs = res+ where res = OM "OMA" [] + (concat (listOMS: map (writeOMObj . toOM) xs))+ -- no, we don't!+ -- fromOM _ = error "list conversion from OM not supported"+ -- or should we?+ fromOM (OM "OMA" [] listXML) + = case parsed of + Left msg -> passError msg+ Right (Document _ _ (Elem oma [] ((CElem lSym):elems)) _)+ -> if isMatrixSym lSym + then mkList elems+ else + if isListSym lSym + then mkList elems + else passError "not a list1"+ Right other -> passError "not a list2"+ where -- use xmlParse' to deconstruct+ parsed = xmlParse' "list-parse" + ("<OMA>" ++ trim listXML ++ "</OMA>")+ -- String trimming (remove white). definition below.+ mkList = map (fromOM . parseOM) . + filter (not . all isSpace) . -- rule out \n+ map verbatim + passError msg = error ("cannot parse as a list:"+ ++ take 100 listXML + ++ "..: " ++ msg)+ fromOM other = error ("list-parse: " ++ take 100 (show other)+ ++ "...\n is not a list.")++emptySymbol = [("cd", (AttValue [Left "set1"])),+ ("name", (AttValue [Left "emptyset"]))]+listSymbol = [("cd",(AttValue [Left "list1"])),+ ("name",(AttValue [Left "list"]))]++setSymbol = [("cd", (AttValue [Left "set1"])),+ ("name", (AttValue [Left "set"]))]++finiteSymbol = [("cd", (AttValue [Left "finfield1"])), ("name", (AttValue [Left "primitive_element"]))]+matrixSymbol = [("cd", (AttValue [Left "linalg2"])), ("name", (AttValue [Left "matrix"]))]+matrixRowSymbol = [("cd", (AttValue [Left "linalg2"])), ("name", (AttValue [Left "matrixrow"]))]+arithPowerSym = [("cd", (AttValue [Left "arith1"])), ("name", (AttValue [Left "power"]))]+mulPowerSym = [("cd", (AttValue [Left "arith1"])), ("name", (AttValue [Left "times"]))]+rationalSym = [("cd", (AttValue [Left "nums1"])), ("name", (AttValue [Left "rational"]))]++listOMS = verbatim (Elem "OMS" listSymbol [])+matrixOMS = verbatim (Elem "OMS" matrixSymbol [])+matrixRowOMS = verbatim (Elem "OMS" matrixRowSymbol [])+rationalOMS = verbatim (Elem "OMS" rationalSym [])+isListSym (Elem "OMS" s []) | s == listSymbol || s == matrixRowSymbol || s == setSymbol = True+ | otherwise = error ("isListSym:" ++ (show s))+isListSym other = False++isEmptySym (Elem "OMS" x []) | x == emptySymbol = error "here!"+isEmptySym _ = False++isArithPowerSym (Elem "OMS" s []) = s == arithPowerSym+isArithPowerSym _ = False++isRationalSym (Elem "OMS" s []) = s == rationalSym+isRationalSym _ = False++isArithMulSym (Elem "OMS" s []) = s == mulPowerSym+isArithMulSym _ = False++isMatrixSym (Elem "OMS" s []) = s == matrixSymbol+isMatrixSym other = False++isMatrixRowSym (Elem "OMS" s []) = s == matrixRowSymbol+isMatrixRowSym other = False++isFiniteSym (Elem "OMS" s []) = s == finiteSymbol+isFiniteSym other = False+++\end{code}++\subsection*{SCSCP message data type}++The following messages are described by the SCSCP spec., and mapped to+a Haskell type (containing useful other types for encoding).++\begin{code}+-- aliases+type CallID = String+type CATime = Int -- ?too coarse?+type CAMem = Int++-- type for CA references (stored inside the server)+newtype CARef = CARef String -- to be embedded in an OMR object+ deriving (Eq,Read,Show)++instance NFData CARef where+ rnf (CARef s) = rnf s+-- no instance Trans, should stay local!+++instance OMData CARef where + toOM (CARef s) = OM "OMR" [("xref",AttValue [Left s])] "" + fromOM (OM "OMR" attribs "" ) = CARef xref + where attribute = lookup "xref" attribs + AttValue ((Left xref):_) = fromJust attribute + fromOM other = error ("cannot treat " ++ show other ++ " as OM-ref.") ++-- type for commands to execute. Either a standard operation (defined+-- in scscp2 CD), or a server-provided operation encoded as+-- (cd-name,op-name)+type CAName = Either (String,String) CAStandardName++data SCSCPMsg = -- to CA System+ PCall { pcCallID :: CallID+ , pcName :: CAName+ , pcData :: [OMObj] + , pcOpts :: ProcOptions }+ | PInterrupt -- empty content (!! can cause race condition !!)+ -- from CA System+ -- procedure complete: called Proc.Result here+ | PResult { prResult :: OMObj+ , prCallID :: CallID+ , prTime :: Maybe CATime+ , prMem :: Maybe CAMem }+ | PTerminated { ptCallID :: CallID+ , ptReturned :: CAError+ , ptTime :: Maybe CATime+ , ptMem :: Maybe CAMem }+ deriving (Show)++-- we will often need to extract the callID immediately:+callID :: SCSCPMsg -> CallID+callID (PCall cid _ _ _) = cid+callID (PResult _ cid _ _) = cid+callID (PTerminated cid _ _ _) = cid++-- encoded procedure options for PCall+data ProcOptions = PCOpts { pcResult :: Maybe PResultOption+ , pcMaxTime :: Maybe CATime+ , pcMinMem :: Maybe CAMem+ , pcMaxMem :: Maybe CAMem + , pcDebug :: Maybe Int }+ deriving (Read,Show)++-- scscp1 defines the following names: option_debuglevel,+-- option_max_memory, option_min_memory, option_runtime+nMaxTime= "option_runtime"+nMaxMem = "option_max_memory"+nMinMem = "option_min_memory"+nDebug = "option_debuglevel"++data PResultOption = Result | ResultRef | NoResult+ deriving (Read,Show)++-- defined following scscp1: option_return_cookie,+-- option_return_nothing, option_return_object,+decodeResultOption :: String -> PResultOption+decodeResultOption "option_return_nothing" = NoResult+decodeResultOption "option_return_cookie" = ResultRef+decodeResultOption "option_return_object" = Result+-- decodeResultOption other = Result -- defaulting+decodeResultOption other = error ("not a result option:" ++ other)++encodeResultOption :: PResultOption -> String -- XML+encodeResultOption NoResult = "option_return_nothing"+encodeResultOption ResultRef = "option_return_cookie" +encodeResultOption Result = "option_return_object"++defaultProcOptions = PCOpts (Just Result) Nothing Nothing Nothing Nothing+-- HWL: WAS:+-- defaultProcOptions = PCOpts Nothing Nothing +-- Nothing Nothing Nothing++writeOpts :: CallID -> ProcOptions -> String +writeOpts callId (PCOpts res maxtime minmem maxmem debug)+ = prefix ++ "\"call_id\" /><OMSTR>" -- HWL: WAS: "call_ID"+ ++ encodeXML callId ++ "</OMSTR>"+ ++ maybeResOpt ++ + concat (zipWith maybeWriteInt + [nMaxTime,nMinMem,nMaxMem,nDebug]+ [maxtime,minmem,maxmem,debug])+ where maybeResOpt = case res of + Nothing -> ""+ Just r -> prefix + ++ show (encodeResultOption r)+ ++ " /><OMSTR></OMSTR>"+ maybeWriteInt name value = case value of + Nothing -> ""+ Just i -> prefix ++ show name + ++ " />"+ ++ writeOMObj + (toOM (i::Int))+ prefix = "<OMS cd=\"scscp1\" name="++-- encoded errors inside PTerminated. The error type is determined+-- from scscp1 definitions, and the error message assembled+-- accordingly. We have taken these ones from the SCSCP-1.2 spec.+data CAError = CAMsg String -- all-purpose+ | CAMemExhausted+ -- rest: future use, currently not in scscp CDs+ | CAInvalidRef -- CARef + | CAInterrupted+ | CANoSuchProc CAName+ | CATimeExhausted+ | SystemError String -- for our own error(s)+ deriving (Read,Show)+-- scscp1 CD and SCSCP-1.2 spec. are a little inconsistent, however:+-- the CD only contains 3 names, which do not clearly map to these+-- different error types.+errTypeName :: CAError -> String+errTypeName CAMemExhausted = "error_memory"+errTypeName CATimeExhausted= "error_runtime"+errTypeName (CAMsg _) = "error_system_specific"+-- other error types go here in the future... +errTypeName _ = "error_system_specific"++errText :: CAError -> String+-- clearly, pass on errors from CA system:+errText (CAMsg msg) = msg+-- I added sensible text for these, unsure. The messages should follow+-- a canonical format if there is one:+errText (CAInvalidRef ) -- (CARef r)) + = "invalid reference " -- ++ r+errText (CANoSuchProc (Left (cd,name))) + = "procedure " ++ name + ++ " does not exist in " ++ cd+-- this would need no text, if scscp1 defined an own error type+errText CAInterrupted = "Interrupted"+errText CAMemExhausted = ""+-- SCSCP-1.2 spec gives an example which implies:+--errText CAMemExhausted = "Exceeded the permitted memory"+errText CATimeExhausted = ""+errText (SystemError s) = "sys error:" ++ s++-- writing out add. information for PTerminated and PResult messages.+-- Would be needed for a server... we add it for completeness.+writeInfos :: CallID -> Maybe CATime -> Maybe CAMem -> String+writeInfos id t mem + = "<OMS cd=\"scscp1\" name=\"call_id\" />" -- HWL: was call_ID+ ++ "<OMSTR>" ++ id ++ "</OMSTR>"+ ++ maybeTime ++ maybeMem+ where maybeTime = case t of + Nothing -> ""+ Just t -> "<OMS cd=\"scscp1\" " + ++ "name=\"info_runtime\" />"+ ++ writeOMObj (toOM t)+ maybeMem = case mem of + Nothing -> ""+ Just m -> "<OMS cd=\"scscp1\" " + ++ "name=\"info_memory\" />"+ ++ writeOMObj (toOM m)+++\end{code}++SCSCP assumes initial exchange of technical information messages (see+below), after which a sequence of dialogs between the client and SCSCP+server is performed, where the client sends a sequence of \cd{PCall}+messages, and the server responds each of them, in their original+order, with a corresponding \cd{PResult} or \cd{PTerminated} message.+The specification describes \cd{CallID} as a convenience and debug+feature only.++Clients can also send an \cd{PInterrupt} message, containing no+data. Its semantics on receiver (server) side is to stop the+\emph{current} procedure immediately, further ones might be in the+message queue of the server (and are not affected), there is no way of+addressing one of the several \cd{PCalls} using \cd{PInterrupt}, and+the server immediately reacts.++\subsection{Assumed standard procedures}++SCSCP assumes a set of standard procedures (e.g. to request supported+operations from a server), which we encode as follows and may be used+as \cd{pcName} in a \cd{PCall}.++\begin{code}+data CAStandardName = GetAllowedHeads -- returns "symbol_sets" + | GetSignature -- HWL: could encode cd and name as args here+ -- returns "signature"+ -- (OMSymbol,minarg,maxarg,(list of) symbol_sets )+ -- JB: pTerminated if not supported? Guess so.+ | GetTransientCD -- returns server-specific Content Dictionary+ -- (should prefix SCSCP_transient_)+ | GetServiceDescr -- returns "service_description", + -- containing 3 Strings: + -- CA system name, version, and descriptive text+ | StoreObj -- computes an object, stores it and returns CARef+ | RetrieveObj -- CARef -- takes ref, returns the OMObj+ | UnbindObj -- CARef -- deletes a CARef'ed object from the server+ deriving (Eq,Read,Show)++-- this follows the scscp2 CD as published online+encodeOp :: CAStandardName -> String+encodeOp GetAllowedHeads = "get_allowed_heads" +encodeOp GetSignature = "get_signature"+encodeOp GetTransientCD = "get_transient_cd"+encodeOp GetServiceDescr = "get_service_description"+encodeOp StoreObj = "store"+encodeOp RetrieveObj = "retrieve" -- CARef to be added!+encodeOp UnbindObj = "unbind" -- deletes a CARef'ed, to be added!++decodeOp :: String -> CAStandardName+decodeOp "get_allowed_heads" = GetAllowedHeads+decodeOp "get_signature" = GetSignature +decodeOp "get_transient_cd" = GetTransientCD+decodeOp "get_service_description" = GetServiceDescr+decodeOp "store" = StoreObj+decodeOp "retrieve" = RetrieveObj + -- (RetrieveObj undefined) -- CARef to be added!+decodeOp "unbind" = UnbindObj + -- (UnbindObj undefined) -- CARef to be added!+decodeOp other = error ("not a standard name: " ++ other)+\end{code}++These routines are called when handling the corresponding CAStandardName:++\begin{code}+constructServiceDescr name version descr = + OM "OMA" atts (Data.List.concat (Data.List.intersperse "\n" (map writeOMObj [(toOM name), (toOM version), (toOM descr)])))+ where atts :: [Attribute]+ atts = [("cd" ,AttValue [Left "scscp2"]),+ ("name",AttValue [Left "service_description"] ) ]++\end{code}++\textbf{TODO:} constructor functions for all CAStandardName++\subsection*{The XML format specification}++Part 4 of the spec. contains an informal specification of the+messages, which we reproduce here for documentation.+\begin{itemize}+\item Procedure Call (\cd{PCall})+\begin{xcode}+<OMOBJ>+ <OMATTR>+ <!-- beginning of attribution pairs -->+ <OMATP>+ <OMS cd="scscp1" name="call_id" /> + <OMSTR>call_identifier</OMSTR> + <OMS cd="scscp1" name="option_runtime" /> + <OMI>runtime_limit_in_milliseconds</OMI> + <OMS cd="scscp1" name="option_min_memory" /> + <OMI>minimal_memory_required_in_bytes</OMI> + <OMS cd="scscp1" name="option_max_memory" /> + <OMI>memory_limit_in_bytes</OMI> + <OMS cd="scscp1" name="option_debuglevel" /> + <OMI>debuglevel_value</OMI> + <OMS cd="scscp1" name="option_return_object" />+ <!-- another possibility is "option_return_cookie" -->+ <OMSTR></OMSTR>+ </OMATP>+ <!-- Attribution pairs finished, now the procedure call -->+ <OMA>+ <OMS cd="scscp1" name="procedure_call" />+ <OMA>+ <!-- "SCSCP_transient_" is an obligatory prefix+ in the name of a transient CD -->+ <OMS cd="SCSCP_transient_identifier"+ name="NameOfTheProcedureRegisteredAsWebService" />+ <!-- Argument 1 -->+ <!-- ... -->+ <!-- Argument M -->+ </OMA> + </OMA>+ </OMATTR>+</OMOBJ>+\end{xcode}+ \jbcomment{So why are these call attributes not XML attributes? + Must be because OpenMath had to be left unmodified. IMHO, an extension by + a new tag would have been the way to go... including all PC attributes as + real XML attributes, and containing the argument list only}++\item Interrupt Signal (\cd{PInterrupt}): no content at all.++\item Procedure Completed (\cd{PResult})+\begin{xcode}+<OMOBJ>+ <OMATTR>+ <!-- Attribution pairs, dependently on the debugging level+ may include procedure name, OM object for the original+ procedure call, etc. -->+ <OMATP>+ <OMS cd="scscp1" name="call_id" />+ <OMSTR>call_identifier</OMSTR>+ <OMS cd="scscp1" name="info_runtime" />+ <OMI>runtime_in_milliseconds</OMI>+ <OMS cd="scscp1" name="info_memory" />+ <OMI>used_memory_in_bytes</OMI>+ </OMATP>+ <!-- Attribution pairs finished, now the result -->+ <OMA>+ <OMS cd="scscp1" name="procedure_completed" />+ <!-- The result itself, may be OM symbol for cookie -->+ <!-- OM_object_corresponding_to_the_result -->+ </OMA>+ </OMATTR>+</OMOBJ>+\end{xcode}++And for referenced data (stored in CA), the following (called a cookie):+\begin{xcode}+<OMOBJ>+ <OMATTR>+ <OMATP>+ <OMS cd="scscp1" name="call_id" />+ <OMSTR>call_identifier</OMSTR>+ </OMATP>+ <OMA>+ <OMS cd="scscp1" name="procedure_completed"/>+ <OMR xref="CAS_variable_identifier" />+ </OMA>+ </OMATTR>+</OMOBJ>+\end{xcode}++\item Procedure Terminated (\cd{PTerminated})+\begin{xcode}+<OMOBJ>+ <OMATTR>+ <!-- beginning of attribution pairs -->+ <OMATP>+ <OMS cd="scscp1" name="call_id" />+ <OMSTR>call_identifier</OMSTR>+ <OMS cd="scscp1" name="info_runtime" />+ <OMI>runtime_in_milliseconds</OMI>+ <OMS cd="scscp1" name="info_memory" />+ <OMI>used_memory_in_bytes</OMI>+ </OMATP>+ <!-- end of attribution pairs -->+ <!-- now the application part of the OM object -->+ <OMA>+ <OMS cd="scscp1" name="procedure_terminated" />+ <OME>+ <OMS cd="scscp1" name="name_of_standard_error"/>+ <!-- Error description depends on error type -->+ <OMSTR>Error_message</OMSTR>+ </OME>+ </OMA>+ </OMATTR>+</OMOBJ>+\end{xcode}+\end{itemize}++\subsection*{Message exchange between client and server}++This is mostly done using XML processing instructions. +The initialisation is a sequence of messages as follows, where +things like attribute order and format is strictly fixed.++Examples: +\begin{xcode}+Server -> Client:+<?scscp service_name="MuPADserver" service_version="1.1"+service_id="host:26133" scscp_versions="1.0 3.4.1 1.2special" ?>++Client -> Server:+<?scscp version="1.0" ?>++Server -> Client:+<?scscp version="1.0" ?>+\end{xcode}+\begin{xcode}+Server -> Client:+<?scscp service_name="MuPADserver" service_version="1.1"+service_id="host:26133" scscp_versions="1.0 3.4.1 1.2special" ?>++Client -> Server:+<?scscp version="2.0" ?>++Server -> Client:+<?scscp quit reason="not supported version 2.0" ?>++OR JUST: <?scscp quit ?>+\end{xcode}++The actual data messages are enclosed in processing instruction blocks:+\begin{xcode}+<?scscp start ?>+... message (OpenMath object), formats see above...+<?scscp end ?>+\end{xcode}+The exception is the interrupt signal, which is just SIGUSR2 to the server.++Messages can be canceled using \verb!<?scscp cancel ?>! to close the block. +The server should not process the message.++Sessions are terminated using \verb!<?scscp quit ?>!, optionally+giving a reason as above.++\begin{code}+-- PIs as a data type:+data SCSCP_PI = Init { piInitName :: String+ , piInitV :: String+ , piInitID :: String+ , piInitSCSCPs :: [String]}+ | Version String+ | Quit (Maybe String)+ | Start | End | Cancel+ | Other String -- catch-all... (for kant extensions)+ deriving (Eq,Show)++piPrefix = "<?scscp"++writePI :: SCSCP_PI -> String+writePI Start = piPrefix ++ " start ?>"+writePI End = piPrefix ++ " end ?>"+writePI Cancel = piPrefix ++ " cancel ?>"+writePI (Quit Nothing) = piPrefix ++ " quit ?>"+writePI (Quit (Just txt)) = piPrefix ++ " quit reason=" ++ show txt ++ " ?>"+writePI (Version ver) = piPrefix ++ " version=" ++ show ver ++ " ?>"+writePI (Init n v iD vs) = piPrefix + ++ " service_name=" ++ show n+ ++ " service_version=" ++ show v+ ++ " service_id=" ++ show iD+ ++ " scscp_versions=" ++ show (unwords vs) + ++ " ?>"+writePI (Other msg) = piPrefix ++ ' ':msg ++ " ?>"++parsePI :: String -> SCSCP_PI+parsePI ('<':'?':'s':'c':'s':'c':'p':' ':more) + = parse' (init ( init (dropWhile isSpace more)))+parsePI other = error ("cannot parse this as a PI: " ++ other)+{- <?scscp start ?>+ <?scscp cancel ?> + <?scscp end ?>+ <?scscp quit reason="blabla" ?>+ <?scscp version="X" ?>+ <?scscp service_name="A" service_version="B" + service_id="C" scscp_versions="D" ?>+-- libkant 4.0 uses these as well: + <?scscp error text="blabla" ?>+ <?scscp info text="blabla" ?>+-}+parse' ('s':'t':'a':'r':'t':_) = Start+parse' ('c':'a':'n':'c':'e':'l':_) = Cancel+parse' ('e':'n':'d':_) = End+parse' ('q':'u':'i':'t':rest)+ | all isSpace rest = Quit Nothing+ | otherwise = Quit text+ where text = case dropWhile isSpace rest of + ('r':'e':'a':'s':'o':'n':'=':'\"':t) + -> Just (takeWhile (not . isQ) t)+ other -> Nothing -- invalid PI, cannot parse.+parse' ('v':'e':'r':'s':'i':'o':'n':'=':'\"':ver)+ = Version (takeWhile (not . isQ) ver)+parse' ('s':'e':'r':'v':'i':'c':'e':'_':'n':'a':'m':'e':'=':'\"':rest)+ -- init message, we assume the attribute order given in the spec.+ = let (name,r2) = splitAndTrimWhen isQ rest+ -- drop "service_version=\""+ r3 = tail' (dropWhile (not . isQ) r2)+ (v,r4) = splitAndTrimWhen isQ r3+ -- drop "service_id=\""+ r5 = tail' (dropWhile (not . isQ) r4)+ (iD,r6) = splitAndTrimWhen isQ r5+ -- drop "scscp_versions=\""+ r7 = tail' (dropWhile (not . isQ) r6)+ vList = words (takeWhile (not . isQ) r7)+ -- yes, I know this is the state monad.+ in Init name v iD vList+-- parse' ('e':'r':'r':'o':'r':' ':'t':'e':'x':'t':'=':'\"':rest)+-- = Other "error text =\"" ++ rest+parse' other = Other other -- return anything as-is otherwise++\end{code}++\section*{Some string search and trim operations (helpers)}+\begin{code}+-- cut a string at the first char. for which a predicate holds,+-- dropping the last character and trimming the rest of whitespaces.+splitAndTrimWhen :: (Char -> Bool) -> String -> (String,String)+splitAndTrimWhen pred "" = ("","")+splitAndTrimWhen pred (c:cs) | pred c = ("",dropWhile isSpace cs)+ | otherwise + = let (a,b) = splitAndTrimWhen pred cs+ in (c:a,b)+tail' :: [a] -> [a] -- never fails+tail' [] = []+tail' xs = tail xs+isQ :: Char -> Bool+isQ '\"' = True+isQ '\'' = True+isQ _ = False+++-- boyer-moore implementation. might be useful later.+boyerMoore :: String -> String -> Maybe Int -- position of first match+boyerMoore pattern searched = bm searched 0+ where bm str i | null rest = if match == pattern + then Just i else Nothing+ | and matching = Just i -- found it+ | otherwise = bm skipped (i+skip firstBad)+ where (match,rest) = splitAt l str+ matching = zipWith (==) pattern match + firstBad = fst (last notMatched)+ notMatched = filter (not . snd) + (zip match matching)+ skipped = drop (skip firstBad) str+ -- simplified, we only use the "bad-pattern" rule+ skip c = length (takeWhile (/= c) rPat)+ rPat = reverse pattern+ l = length pattern++trim :: String -> String+trim = dropWhile isSpace ++\end{code}++\newpage++\section*{Module overview of the Haskell SCSCP client}++\begin{center}+\includegraphics[width=0.9\textwidth]{modules}+\end{center}++The following modules are combined to the SCSCP API:+\begin{itemize}+ \item[\cd{SCSCP\_DTD}] conversion from XML to an intermediate data+ type.\\ +%+ This file is generated from \cd{SCSCP.dtd} via DTDtoHaskell+ (HaXml), and then retouched to avoid decomposing objects deeper+ than necessary.+ \item[\cd{Hs2SCSCP}] Conversion from Haskell structures to SCSCP XML+ and vice-versa. Uses the \cd{SCSCP\_DTD} as intermediate data.+ \item[\cd{HS\_SCSCP}] This file. Provides all SCSCP-relevant data+ types, no functionality.+ \item[\cd{SCSCP\_API}] server access functions and start/stop+ actions, functions for SCSCP evaluation.+\end{itemize}++\section*{System architecture intended for SymGrid-Par}++\hwlcomment{A more detailed discussion of the SymGrid-Par + design is given in my overview talk at the SCIEnce workshop in October.}++\begin{center}+\includegraphics[width=0.7\textwidth]{architecture1}++\bigskip+\includegraphics[width=0.7\textwidth]{architecture2}+\end{center}++\subsection*{Coordination Server}++\hwlcomment{Documentation to be filled in}++% The coordination server uses techniques which we have tested in+% the SCSCP client, and completely rely on the \cd{Hs2SCSCP.hs} for+% SCSCP.++% -----------------------------------------------------------------------------+% TODO: check whether any of this is still relevant++% \newpage++% {\huge Junkyard: outdated material }++% {\bf Notes on SCSCP specification and examples }++% \begin{itemize}++% \item error message data unclear:++% The description of error messages (procedure terminated)+% differs from the given examples, in that the examples+% do not give runtime and memory.+% The text says that these will be included in an+% error message.++% \item error messages under-specified in scscp1 CD and description: + +% The textual description of error messages categorises a few+% error types, which is not reflected by the scscp1 CD and neither+% the examples given later. ++% The following is missing from scscp1:+% ``terminated by interrupt'', ``invalid cookie'', +% ``ran out of resource(time)''.++% The exact meaning of ``procedure not supported'' and +% of ``cannot compute OM Object'' remains unclear.++ ++% \item invalid XML in example B.3:++% Example B.3 shows an error message from the CA system +% (actually, GAP) which contains literally +% \verb!<function>(<arguments>)!. As one can expect, this +% causes an XML parse error (parsing tags named ``function''+% and ``argument'' instead of plain text).+% The CA system should either wrap any unchecked text in +% the OMSTR into \verb!<[[CDATA the-unchecked-text ]]>! or (better) +% encode $<$ and $>$ as necessary for XML.+% The website describing the scscp1 CD does the latter, +% correctly.++% Just a flaw in the example, or a problem of the gap server?+++% \item inconsistency between scscp1 CD and Spec. 1.2 examples:++% The example for proc.terminated with a CA system error given in the+% SCSCP-1.2.pdf uses \verb!name="error_CAS"!, whereas the scscp1+% CD specifies a \verb!error_system_specific!.++% \item (Question?) isn't the call\_id mandatory, and thereby+% OMATTR/OMATP a required content for any SCSCP message?++% SCSCP-1.2.pdf, p.4 bottom, reads as if it was mandatory. ++% Examples for \verb!error_*! in scscp1 CD do not give any OMATP,+% nor do they show the expected ``procedure\_terminated'' frame+% inside which one will expect the error types to appear.++% \end{itemize}
+ src/Math/ComputerAlgebra/Cash/Monitor.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE ForeignFunctionInterface #-}+----------------------------------------------------------------------------+-- (c) 2010+-- Hans-Wolfgang Loidl <hwloidl@cs.st-andrews.ac.uk>+-- code clean-up and port to ghc-6.12.2+-- +-- (c) 2008+-- Jost Berthold <berthold@mathematik.uni-marburg.de>+-- introduced more accurate types and included header file+-- +--+-- (c) 2006+-- Abdallah Al Zain <ceeatia@macs.hw.ac.uk>+-- +-- this module is intended to bypass the heap, stack of an ordinary STG machine+-- provding an interface to an external repository, (hence a side-effect).+-----------------------------------------------------------------------------+module Math.ComputerAlgebra.Cash.Monitor where++import Foreign.StablePtr+import Foreign.Ptr -- for NULL pointer+ -- types only+import System.IO -- IO,Handle+import Control.Concurrent++#ifndef __PARALLEL_HASKELL__+-- version for testing with ghci, no C stuff involved+import System.IO.Unsafe+import Control.Monad++-- data is stored in CAF. We cannot do this in a parallel version,+-- because we cannot rely on per-PE execution.+{-# NOINLINE storageVar #-}+storageVar :: MVar (StablePtr (MVar a))+storageVar = unsafePerformIO (newEmptyMVar)++cwriteMVarPointer :: StablePtr (MVar a) -> IO()+cwriteMVarPointer ptr = do+ empty <- isEmptyMVar storageVar+ when (not empty) (takeMVar storageVar >> return ()) -- empty it+ putMVar storageVar ptr++cdeleteMVarPointer :: IO ()+cdeleteMVarPointer = do + empty <- isEmptyMVar storageVar+ if empty then return () + else do takeMVar storageVar+ return ()++creadMVarPointer :: IO (StablePtr (MVar a))+creadMVarPointer = do + empty <- isEmptyMVar storageVar+ if empty then return (castPtrToStablePtr nullPtr)+ else readMVar storageVar++-- ID supply, hand-rolled.+{-# NOINLINE idVar #-}+idVar :: MVar Integer -- overflow impossible, but IDs may get very long!+idVar = unsafePerformIO (newMVar 0)++newID :: IO String+newID = do i <- takeMVar idVar+ putMVar idVar (i+1)+ return ("HsSCSCP" ++ show i)++#else++foreign import ccall unsafe + "monitor.h cwriteMVarPointer" cwriteMVarPointer + :: StablePtr (MVar a) -> IO()+foreign import ccall unsafe + "monitor.h cdeleteMVarPointer" cdeleteMVarPointer + :: IO ()+foreign import ccall unsafe+ "monitor.h creadMVarPointer" creadMVarPointer + :: IO (StablePtr (MVar a))++foreign import ccall unsafe + "monitor.h cwriteIDVarPointer" cwriteIDVarPointer + :: StablePtr (MVar Integer) -> IO()+foreign import ccall unsafe + "monitor.h cdeleteIDVarPointer" cdeleteIDVarPointer + :: IO ()+foreign import ccall unsafe+ "monitor.h creadIDVarPointer" creadIDVarPointer + :: IO (StablePtr (MVar Integer))++-- ID supply for PARALLEL_HASKELL+idInit :: IO (StablePtr (MVar Integer))+idInit = do v <- newMVar 0+ p <- newStablePtr v+ cwriteIDVarPointer p+ return p++-- will surely never be used...+idCancel :: IO ()+idCancel = cdeleteIDVarPointer++newID :: IO String+newID = do p <- creadIDVarPointer+ -- check if null, init if so+ let checkP = castStablePtrToPtr p+#warning -- check for race condition+ p' <- if (checkP == nullPtr) then idInit + else return p+ idVar <- deRefStablePtr p+ i <- modifyMVar idVar ( \n -> return (n+1,n)) + -- take -> (put,return)+ return ("HsSCSCP" ++ show i)++#endif
+ src/Math/ComputerAlgebra/Cash/SCSCP_API.hs view
@@ -0,0 +1,433 @@+{-# OPTIONS -cpp -XScopedTypeVariables -XPatternSignatures #-}+{-+Time-stamp: <Tue Apr 13 2010 22:44:14 Stardate: Stardate: [-28]2914.52 hwloidl>++Sequential SCSCP interface +-}+++module Math.ComputerAlgebra.Cash.SCSCP_API (+ SCSCPServer(..)+ , defaultServer, mockingServer, server+ , startServer, stopServer+ , initServer, releaseServer+ , exchangeSCSCP+ , callSCSCP+ , module Math.ComputerAlgebra.Cash.HS_SCSCP -- required data types ++ -- below: mostly internal. for now, export all for ghci debugging+ , module Math.ComputerAlgebra.Cash.HS2SCSCP+ , checkServerState+ , readBlock, readUntilPI, splitAtPI, + ) where++-- date, release etc info+import Math.ComputerAlgebra.Cash.Date++-- our SCSCP framework. +import Math.ComputerAlgebra.Cash.HS2SCSCP+import Math.ComputerAlgebra.Cash.HS_SCSCP+-- maybe redundant, reading in XML:+-- import SCSCP_DTD++-- library stuff:+import System.IO -- handles and I/O+import System.IO.Unsafe(unsafePerformIO)++import Control.Monad -- evaluation and execution control throughout...+import Control.Parallel.Strategies -- MUST be parallel-1.xx+import Control.Concurrent -- MVar and threadDelay+#if __GLASGOW_HASKELL__ > 610+import Control.OldException as C -- catching severe errors + -- => shutting down the server+#else+import Control.Exception as C -- catching severe errors + -- => shutting down the server+#endif++import Network -- for communication with the SCSCP server++import Foreign.StablePtr -- given a pointer, prevents its bound object+ -- to be affected by the garbage collector + -- useful to simulate a "imperative persitent + -- state" in the interface. See subsquent.+import Math.ComputerAlgebra.Cash.Monitor -- An "external state" using the FFI.+import Foreign.Ptr(nullPtr) -- integrity checks only++#ifdef __PARALLEL_HASKELL__+#warning System.Process used here. Status: experimental+import System.Process -- forking an own SCSCP server process+#endif++import System.Environment(getEnv)++#ifdef __PARALLEL_HASKELL__+import Eden(Trans) -- Enabling remote processes in a functional style.+import Edi -- lower level control, spawning remote IO(),+ -- synchronising via messages+#endif++#ifdef DEBUG+import Debug.Trace+#else+-- this eliminates the trace calls when compiling with -O or -O2+{-# RULES "notrace" forall a b. trace a b = b #-}+trace _ x = x+#endif+traceM :: String -> IO ()+traceM msg = trace msg (return ()) +++-- we follow the document "SCSCP-1.2.pdf", thus:+#define CLIENTVERSION "1.2"++--------------------------------------------------+-- SCSCP servers:++data SCSCPServer = SCSCPServer + { scscpHost :: String+ , scscpPort :: PortID + -- system exec. path, commands to start scscp+ , startData :: Maybe (String,[String])+ }++-- our own dummyServ.hs+dummyServ = server "localhost" (Just 12321)++-- port number taken from SCSCP-1.2 spec., assuming localhost+defaultServer = SCSCPServer "localhost" (PortNumber 26133) Nothing++-- testing in st.andrews+mockingServer = server + "chrystal.mcs.st-andrews.ac.uk" + Nothing --std.port++issel = server "issel.math.tu-berlin.de" Nothing ++server :: String -> Maybe PortNumber -> SCSCPServer+server name Nothing = defaultServer{scscpHost=name}+server name (Just port) = defaultServer{scscpHost=name,+ scscpPort=PortNumber port}++-- we might want to start our own instance from Haskell, and will+-- store the handle in just the same way as if it was an already+-- started server which we only use.+startServer :: IO SCSCPServer -- start own server (fork process)+stopServer :: IO () -- stop own server (kill process)+startServer = error "start server: not implemented"+stopServer = error "stop server: not implemented"++-----------------------------------------------------++-- reads the global MVar pointer, returns whether ptr!=nullPtr.+-- True means, server is initialised and listening.+checkServerState :: IO Bool+checkServerState = do checkStP <- creadMVarPointer+ let checkP = castStablePtrToPtr checkStP+ return (checkP /= nullPtr)++-- pass error to someone inside the IO monad.+passError :: String -> IO a+passError = return . error++-- on severe errors, release server, complain, and pass error +severeError :: String -> IO a+severeError msg = do + traceM "severeError"+ check <- checkServerState+ when check (trace "shutting down in severeError" $+ C.catch releaseServer (\(e::Exception) -> trace (show e) $ return ()))+ putStrLn "Severe error, shutting down the server connection"+ passError msg+++-- start server communication. Connects to a given server, exchanges+-- init. messages, then stores a server handle in the global state.+initServer :: SCSCPServer -> IO ()+initServer srv = withSocketsDo $ + do check <- checkServerState + if check + then do traceM "busy... aborting"+ passError "init: HS interface already busy"+ else do+ syncVar <- newEmptyMVar+ traceM "connecting..."+ hdl <- connectTo (scscpHost srv) (scscpPort srv)+-- THIS LEADS TO MISFUNCTIONALITY IN THE KANT SERVER+-- hSetBuffering hdl NoBuffering+ -- exchange init messages+ traceM "exchanging init. messages..."+ -- we expect an init message at first, nothing before.+ (_,serverInit) <- splitAtPI hdl+ case serverInit of + (Init n v iD _) -> traceM $ "server " ++ n ++ '(':v+ ++ "),session " ++ iD+ other -> do traceM "unexpected message"+ fail "unexpected server init"+ let vs = piInitSCSCPs serverInit -- versions+ versionCheck = CLIENTVERSION `elem` vs+ traceM ("Version check. Server supports: " ++ unwords vs+ ++ '\n':CLIENTVERSION + ++ (if versionCheck then " " else " NOT ")+ ++ "supported.")+ + -- answer with our version (anyway, let server abort)+ -- woraround for libkant 4.0+ if versionCheck + then hPutStrLn hdl (writePI (Version CLIENTVERSION))+ else let bogusV = Version (last vs)+ in trace ("answering version: " ++ show bogusV)+ (hPutStrLn hdl (writePI (Version (last vs))))+ -- expect server "ready" answer, otherwise fail+ hFlush hdl+ (_,answer) <- splitAtPI hdl+ case answer of + Quit Nothing -> do traceM ("server quit." )+ fail "server quit unexpectedly."+ Quit (Just m) -> do traceM ("server quit with " ++ m )+ fail ("server quit: " ++ m)+ Version str -> traceM "server sez ready"+ other -> do traceM ("unexpected server message"+ ++ show other)+ fail "unexpected server answer."+ hPutStrLn hdl "\n"+ hFlush hdl+ -- write out MVar with handle+ putMVar syncVar hdl+ ptr <- newStablePtr syncVar+ cwriteMVarPointer ptr+ traceM "server set up to communicate"++-- terminate communication with the server which has been started by+-- initServer.+releaseServer :: IO ()+releaseServer = do check <- checkServerState+ if not check + then traceM "no server, nothing to stop..."+ else do+ syncP <- creadMVarPointer+ syncVar <- deRefStablePtr syncP+ -- invalidating the MVar pointer+ cdeleteMVarPointer+ -- Now, wait here for the handle in the MVar.+ hdl <- takeMVar syncVar+ C.catch (do + -- terminating the server session by a message+ hPutStrLn hdl (writePI (Quit Nothing))+ -- Possible race condition: in the meantime,+ -- others may still be using the server... queued+ -- waiting for the handle as well. We pass them+ -- an error closure instead of the correct handle+ -- (should not happen in a correct program IMHO).+ ) (\(e::Exception) -> trace ("release failed" ++ show e) $ + return ())+ putMVar syncVar (error "server stopped prematurely")++{-++connection initiation as described in SCSCP-1.2.pdf:++server sends: + <?scscp service_name="A" service_version="B" + service_id="C" scscp_versions="D" ?>++where A is the name of the service (simply a String) ++ B is the version, seems to be numbers and suffixes, like+ 4.5.1beta++ C is a unique identifier for the session (???generated by the+ server, OK... )++ D is a space-separated list of strings (digits,letters,dot)+ which describe scscp versions ++then client sends:+ <?scscp version="CLIENTVERSION" ?>++where CLIENTVERSION *should* be one of the supported versions+ announced by the server in list D++then server sends:+ <?scscp version="SERVERVERSION" ?>++where SERVERVERSION confirms the CLIENTVERSION (same string)+ If the CLIENTVERSION is not supported, the server may + terminate the session by sending + <?scscp quit reason="blabla" ?> instead++Then server and client communicate in sequences of OMOBJ messages,+separated by + <?scscp start ?>+ ...OMOBJ...+ <?scscp end ?>++For canceling a started message,+ <?scscp cancel ?> + may terminate the transaction at any time in-between <?scscp start ?>+ and receiving the total of an OMOBJ.++The SCSCP interrupt is signalled by sending SIGUSR2 to the+server. (???How that, if it is a remote service???)++-}++--------------------------------------------------------+-- Processing instruction stuff: top-level stuff here for +-- convenience, specification-dependent parts in HS_SCSCP +-- (parsePI and according data type)++-- read in characters from handle, until "?>" appears.+-- return all characters read, including the final "?>"+readUntilPI :: Handle -> IO String+readUntilPI h = trace ".. starting to readUntilPI" (accum "")+ where accum :: String -> IO String+ accum acc = do + c <- hGetChar h+ if c /= '?' then (accum (c:acc))+ else -- trace "q.mark!" + (qMark (c:acc))+ qMark :: String -> IO String+ qMark acc = do+ c <- hGetChar h+ case c of + '?' -> qMark (c:acc)+ '>' -> trace ".. finished reading until PI" + (return (reverse (c:acc)))+ other -> accum (c:acc)++-- extract one processing instruction of form "<?scscp ... ?> from a+-- stream received from a handle, deliver the prefix string as well:+splitAtPI :: Handle -> IO (String,SCSCP_PI)+splitAtPI h = do traceM "splitAtPI"+ input <- readUntilPI h+ traceM $ "Input (splitAPI): "++(show input)+ let splitLoc = boyerMoore "<?scscp" input+ case splitLoc of + Nothing -> -- not an scscp PI. try again.+ trace "not for me... retry" + (splitAtPI h)+ Just pos -> do+ let (pre,pi) = splitAt pos input+ thePI = parsePI pi+ return (pre,thePI)++------------------------------------------------------+-- OMOBJ message exchange between client and server:++-- read a "block" of SCSCP, starting by PI Start, ended by PI Cancel+-- or PI End. Deliver message in-between (or nothing if canceled).+readBlock :: Handle -> IO (Maybe String)+readBlock h = do traceM "readBlock"+ (pre,startpi) <- splitAtPI h+ -- kant server workaround+ case startpi of + Other msg -> do traceM ("received this:\n" + ++ pre + ++ "and scscp PI " ++ msg)+ readBlock h+ Start -> do + (block,stoppi) <- splitAtPI h+ traceM ("received " ++ show block)+ case stoppi of+ Cancel -> trace "canceled" $+ return Nothing+ End -> return (Just block)+ Quit reason -> trace ("unexpected PI: Quit with reason " ++ show reason)+ return Nothing+ other -> trace ("unexpected PI: " ++ show other)+ return Nothing+ other -> do traceM ("unexpected PI (start):\n"+ ++ writePI other) + return Nothing++-- Kant server namespace hack: replace all tag prefixes "<OM:" by "<"+removeNamespaceOM :: String -> String+removeNamespaceOM [] = []+removeNamespaceOM [x] = [x]+removeNamespaceOM [x,y] = [x,y]+removeNamespaceOM [x,y,z] = [x,y,z]+removeNamespaceOM [x,y,z,a] = [x,y,z,a]+removeNamespaceOM ('<':'O':'M':':':rest) = '<':removeNamespaceOM rest+removeNamespaceOM ('<':'/':'O':'M':':':rest) = '<':'/':removeNamespaceOM rest+removeNamespaceOM (a:b:c:d:e:other) = a:removeNamespaceOM (b:c:d:e:other)++-- uses the (hopefully) stored server handle to +exchangeSCSCP :: SCSCPMsg -> IO SCSCPMsg+exchangeSCSCP (PResult _ _ _ _) + = passError "PResult from client to server?"+exchangeSCSCP (PTerminated _ _ _ _) + = passError "PTerminate from client to server?"+exchangeSCSCP pcall + = do traceM ".. scscp message exchange... "+ check <- checkServerState+ if not check then error "no server initialised" + else do+ ptr <- creadMVarPointer+ syncVar <- deRefStablePtr ptr+ hdl <- takeMVar syncVar+ traceM $ (".. using handle "++(show hdl)++" to send "++(show pcall))+ open <- (hIsOpen hdl)+ ready <- (hReady hdl)+ traceM $ (".. handle Open? "++(show open)++"; handle ready? "++(show ready))+ C.catch + (do -- synchronised:+ hPutStrLn hdl (writePI Start)+ hFlush hdl+ hPutStrLn hdl (writeSCSCPMsg pcall)+ hFlush hdl+ hPutStrLn hdl (writePI End)+ hFlush hdl+ output <- readBlock hdl+ traceM $ (".. raw reply to send of "++(show (callID pcall))++" is "++(show output))+ putMVar syncVar hdl+ case output of + Just s -> let msg = readSCSCPMsg (removeNamespaceOM s)+ in msg `seq` -- to catch error here+ return msg + Nothing -> return (PTerminated "no-ID" + (SystemError "no output received") + Nothing Nothing)+ ) (\(e::Exception) -> putMVar syncVar hdl >> + severeError ("msg. exchange failed with " ++ show e))++-- TODO: write an asynchronous method.+-- * creates an empty MVar(OMObj) for the result+-- (mechanism might as well use MVar (SCSCPMsg) )+-- * takes handle, writes out PCall+-- * frees server handle+-- * (on success only:) +-- - registers call_ID and MVar in some global store+-- - creates a closure res = [unsafePerformIO] (readMVar resultVar)+-- - returns this closure+-- a (global) answer-reading thread reacts on all answer as follows:+-- * reads answer, extracts call_ID+-- * looks up result MVar in global store+-- * on success: stores the reply++-- bogus-functional interface for PCalls. Name and Arg.list+callSCSCP :: CAName -> [OMObj] -> OMObj+callSCSCP fName args = unsafePerformIO $ do+ traceM ("callSCSCP function " ++ show fName)+ call_ID <- newID+ let pcall = PCall call_ID fName args defaultProcOptions+ answer <- exchangeSCSCP pcall+ if (callID answer /= call_ID) + then do traceM ("wrong callID " ++ callID answer + ++ ", expected " ++ call_ID)+ severeError ("received wrong call ID!!! "++"expected: "++(show call_ID)++" received: "++(show (callID answer))++"\nin the following message\n"++(show answer))+ -- severeError ("received wrong call ID!!!")+ else case answer of + PTerminated _ err t m + -> return (error (errTypeName err ++ "." + ++ errText err))+ PResult res _ t m -> return res++call2 :: (OMData a, OMData b, OMData c) =>+ CAName -> a -> b -> c+-- ------ +-- still ugly :( ++-- use Template Haskell to generate these guys+call2 name x y = fromOM (callSCSCP name [toOM x,toOM y])+
+ src/Math/ComputerAlgebra/Cash/SCSCP_DTD.hs view
@@ -0,0 +1,245 @@+{-+-- Time-stamp: <Thu Mar 25 2010 22:33:01 Stardate: Stardate: [-28]2819.69 hwloidl>++SCSCP Messages to Haskell conversion module.++This code has been generated from a custom DTD for SCSCP messages (not+taking into account the generality of OpenMath, but tailored to SCSCP+messages parsed ++After code generation, the code has been retouched at the marked+places to enable the conversion we want (not parsing into the+arguments/results, but storing them as an opaque OpenMath object (OMO+String)++We also provide additional functions :: OMOBJ -> SCSCPMsg which+convert the parsed data from the intermediate type to the one we want+to use, and vice-versa.++All SCSCP Haskell types are imported from HS_SCSCP (todo: rename!).++Author: Jost Berthold, University of St.Andrews, UK+(c) 12/2008++-}++module Math.ComputerAlgebra.Cash.SCSCP_DTD where++import Text.XML.HaXml.Xml2Haskell+import Text.XML.HaXml+--import Text.XML.HaXml.XmlContent+import Text.XML.HaXml.OneOfN+--import Text.XML.HaXml.XmlContent.Parser+import Char (isSpace)++-- edited: verbatim instance for dummy type+import Text.XML.HaXml.Verbatim++{-Type decls-}++data OMOBJ = OMOBJ OMOBJ_Attrs OMATTR+ deriving (Eq,Show)+data OMOBJ_Attrs = OMOBJ_Attrs+ { oMOBJXmlns'OM :: (Maybe String)+ , oMOBJXmlns'xsi :: (Maybe String)+ , oMOBJXsi'schemaLocation :: (Maybe String)+ , oMOBJVersion :: (Maybe String)+ } deriving (Eq,Show)+data OMATTR = OMATTR (Maybe OMATP) OMA+ deriving (Eq,Show)+data OMS = OMS+ { oMSCd :: String+ , oMSName :: String+ } deriving (Eq,Show)+newtype OMATP = OMATP [(OneOf2 (OMS,OMSTR) (OMS,OMI))] deriving (Eq,Show)+data OMA = OMAOMS_OMR (OMS,OMR)+ | OMAOMS_OME (OMS,OME)+ | OMAOMS_EATALL (OMS,EATALL)+ deriving (Eq,Show)+data OME = OME OMS OMSTR+ deriving (Eq,Show)+newtype OMSTR = OMSTR String deriving (Eq,Show)+newtype OMI = OMI String deriving (Eq,Show)+data OMR = OMR+ { oMRXref :: String+ } deriving (Eq,Show)++-- EATALL stands for arbitrary OpenMath parts passed as arg.s or+-- result. These will be read in as OMObj, see below.++-- Type declaration modified, just decoration for any XML Element.+-- Converter must eat and produce any kind of element (but not text).+-- ??? do we need/should we expect any attributes here???+-- newtype EATALL = EATALL [ANY] deriving (Eq,Show)+newtype EATALL = EAT Element+ deriving (Eq,Show)++instance Verbatim EATALL where+ verbatim (EAT e) = verbatim e++-- for debugging only...+instance Show Element where + show (Elem name [] []) = "<"++name++"/>"+ show (Elem name ((n1,_):_) []) = "<"++name++' ':n1++"=.../>"+ show (Elem name attrs content) = "<"++name++" ...>...</"++name++">"+instance Eq Element where + Elem n1 as1 c1 == Elem n2 as2 c2 = n1 == n2 && + as1 == as2++--eatAllElem :: Element -> EATALL+eatAllElem ((CElem e):rest) = (Just (EAT e),rest)+eatAllElem ((CMisc _):rest) = eatAllElem rest+eatAllElem ((CString _ s):rest) | all isSpace s = eatAllElem rest+eatAllElem other = (Nothing,other)++--produceAllElem :: EATALL -> Element+produceAllElem (EAT e) = CElem e++{-Instance decls-}++instance XmlContent OMOBJ where+ fromElem (CElem (Elem "OMOBJ" as c0):rest) =+ (\(a,ca)->+ (Just (OMOBJ (fromAttrs as) a), rest))+ (definite fromElem "<OMATTR>" "OMOBJ" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMOBJ as a) =+ [CElem (Elem "OMOBJ" (toAttrs as) (toElem a))]+instance XmlAttributes OMOBJ_Attrs where+ fromAttrs as =+ OMOBJ_Attrs+ { oMOBJXmlns'OM = possibleA fromAttrToStr "xmlns:OM" as+ , oMOBJXmlns'xsi = possibleA fromAttrToStr "xmlns:xsi" as+ , oMOBJXsi'schemaLocation = possibleA fromAttrToStr "xsi:schemaLocation" as+ , oMOBJVersion = possibleA fromAttrToStr "version" as+ }+ toAttrs v = catMaybes + [ maybeToAttr toAttrFrStr "xmlns:OM" (oMOBJXmlns'OM v)+ , maybeToAttr toAttrFrStr "xmlns:xsi" (oMOBJXmlns'xsi v)+ , maybeToAttr toAttrFrStr "xsi:schemaLocation" (oMOBJXsi'schemaLocation v)+ , maybeToAttr toAttrFrStr "version" (oMOBJVersion v)+ ]+instance XmlContent OMATTR where+ fromElem (CElem (Elem "OMATTR" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Just (OMATTR a b), rest))+ (definite fromElem "<OMA>" "OMATTR" ca))+ (fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMATTR a b) =+ [CElem (Elem "OMATTR" [] (maybe [] toElem a ++ toElem b))]+instance XmlContent OMS where+ fromElem (CElem (Elem "OMS" as []):rest) =+ (Just (fromAttrs as), rest)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem as =+ [CElem (Elem "OMS" (toAttrs as) [])]+instance XmlAttributes OMS where+ fromAttrs as =+ OMS+ { oMSCd = definiteA fromAttrToStr "OMS" "cd" as+ , oMSName = definiteA fromAttrToStr "OMS" "name" as+ }+ toAttrs v = catMaybes + [ toAttrFrStr "cd" (oMSCd v)+ , toAttrFrStr "name" (oMSName v)+ ]+instance XmlContent OMATP where+ fromElem (CElem (Elem "OMATP" [] c0):rest) =+ (\(a,ca)->+ (Just (OMATP a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMATP a) =+ [CElem (Elem "OMATP" [] (concatMap toElem a))]+instance XmlContent OMA where+ fromElem (CElem (Elem "OMA" [] c0):rest) =+ case (fromElem c0) of+ (Just a,_) -> (Just (OMAOMS_OMR a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Just a,_) -> (Just (OMAOMS_OME a), rest)+ (_,_) ->+ case (fromElem c0) of+ (Just a,_) -> (Just (OMAOMS_EATALL a), rest)+ (_,_) ->+ (Nothing, c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMAOMS_OMR a) = [CElem (Elem "OMA" [] (toElem a) )]+ toElem (OMAOMS_OME a) = [CElem (Elem "OMA" [] (toElem a) )]+ toElem (OMAOMS_EATALL a) = [CElem (Elem "OMA" [] (toElem a) )]+instance XmlContent OME where+ fromElem (CElem (Elem "OME" [] c0):rest) =+ (\(a,ca)->+ (\(b,cb)->+ (Just (OME a b), rest))+ (definite fromElem "<OMSTR>" "OME" ca))+ (definite fromElem "<OMS>" "OME" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OME a b) =+ [CElem (Elem "OME" [] (toElem a ++ toElem b))]+instance XmlContent OMSTR where+ fromElem (CElem (Elem "OMSTR" [] c0):rest) =+ (\(a,ca)->+ (Just (OMSTR a), rest))+ (definite fromText "text" "OMSTR" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMSTR a) =+ [CElem (Elem "OMSTR" [] (toText a))]+instance XmlContent OMI where+ fromElem (CElem (Elem "OMI" [] c0):rest) =+ (\(a,ca)->+ (Just (OMI a), rest))+ (definite fromText "text" "OMI" c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (OMI a) =+ [CElem (Elem "OMI" [] (toText a))]+instance XmlContent OMR where+ fromElem (CElem (Elem "OMR" as []):rest) =+ (Just (fromAttrs as), rest)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem as =+ [CElem (Elem "OMR" (toAttrs as) [])]+instance XmlAttributes OMR where+ fromAttrs as =+ OMR+ { oMRXref = definiteA fromAttrToStr "OMR" "xref" as+ }+ toAttrs v = catMaybes + [ toAttrFrStr "xref" (oMRXref v)+ ]+instance XmlContent EATALL where+ fromElem = eatAllElem+ toElem = (:[]) . produceAllElem+{- edited: use eatAllElem and produceAllElem+ fromElem (CElem (Elem "EATALL" [] c0):rest) =+ (\(a,ca)->+ (Just (EATALL a), rest))+ (many fromElem c0)+ fromElem (CMisc _:rest) = fromElem rest+ fromElem (CString _ s:rest) | all isSpace s = fromElem rest+ fromElem rest = (Nothing, rest)+ toElem (EATALL a) =+ [CElem (Elem "EATALL" [] (concatMap toElem a))]+-}++{-Done-}
+ src/Math/ComputerAlgebra/Cash/SGPTypes.hs view
@@ -0,0 +1,19 @@+module Math.ComputerAlgebra.Cash.SGPTypes where+++data Arith = List [Arith]+ | Rational [Arith] + | Matrix [Arith] + | MatrixRow [Arith] + | Mul FiniteField Int + | Power FiniteField Int + | Polynomial String+ | Num Integer+ | Empty+ deriving (Show, Read, Eq, Ord)++--data MatrixRow = MatrixRow [Arith]+-- deriving (Show, Read, Eq, Ord)++data FiniteField = PrimEl Int+ deriving (Show, Read, Eq, Ord)