diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cash.cabal b/cash.cabal new file mode 100644 --- /dev/null +++ b/cash.cabal @@ -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 diff --git a/misc/SCSCP.dtd b/misc/SCSCP.dtd new file mode 100644 --- /dev/null +++ b/misc/SCSCP.dtd @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/misc/id512.g b/misc/id512.g new file mode 100644 --- /dev/null +++ b/misc/id512.g @@ -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; diff --git a/misc/idperm.g b/misc/idperm.g new file mode 100644 --- /dev/null +++ b/misc/idperm.g @@ -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; diff --git a/misc/karatsuba.g b/misc/karatsuba.g new file mode 100644 --- /dev/null +++ b/misc/karatsuba.g @@ -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; diff --git a/misc/runit.g b/misc/runit.g new file mode 100644 --- /dev/null +++ b/misc/runit.g @@ -0,0 +1,62 @@ +# Time-stamp: +############################################################################# +# 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" ] ] ) diff --git a/misc/sample-sgprc b/misc/sample-sgprc new file mode 100644 --- /dev/null +++ b/misc/sample-sgprc @@ -0,0 +1,2 @@ +localhost 26153 GAP +localhost 26154 GAP diff --git a/misc/sgp_admin.sh b/misc/sgp_admin.sh new file mode 100644 --- /dev/null +++ b/misc/sgp_admin.sh @@ -0,0 +1,161 @@ +#!/bin/bash +# Time-stamp: +# $Id$ +# ----------------------------------------------------------------------------- +# +# Usage: sgp_admin [options] +# +# Administrative commands for the SymGrid-Par installation. +# +# Commands: +# init ... run init script of the installation +# launch ... launch servers specified in a 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 [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 + diff --git a/misc/sgp_client.g b/misc/sgp_client.g new file mode 100644 --- /dev/null +++ b/misc/sgp_client.g @@ -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); diff --git a/misc/sgp_server.g b/misc/sgp_server.g new file mode 100644 --- /dev/null +++ b/misc/sgp_server.g @@ -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( ) +# +# 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( ) +# +# 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 ); diff --git a/misc/sumEuler.g b/misc/sumEuler.g new file mode 100644 --- /dev/null +++ b/misc/sumEuler.g @@ -0,0 +1,87 @@ +# Time-stamp: +# +# 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; diff --git a/src/Math/ComputerAlgebra/.Cash.hs.swp b/src/Math/ComputerAlgebra/.Cash.hs.swp new file mode 100644 Binary files /dev/null and b/src/Math/ComputerAlgebra/.Cash.hs.swp differ diff --git a/src/Math/ComputerAlgebra/Cash.hs b/src/Math/ComputerAlgebra/Cash.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash.hs @@ -0,0 +1,376 @@ +{-# OPTIONS_GHC -cpp -XParallelListComp -XScopedTypeVariables #-} +-- Time-stamp: +-- +-- 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 + diff --git a/src/Math/ComputerAlgebra/Cash/BaseServices.hs b/src/Math/ComputerAlgebra/Cash/BaseServices.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/BaseServices.hs @@ -0,0 +1,129 @@ +{- +Time-stamp: + +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 +-} diff --git a/src/Math/ComputerAlgebra/Cash/CA_Skeletons.hs b/src/Math/ComputerAlgebra/Cash/CA_Skeletons.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/CA_Skeletons.hs @@ -0,0 +1,302 @@ +{-# OPTIONS_GHC -cpp -XParallelListComp #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- Time-stamp: +-- +-- 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) + + diff --git a/src/Math/ComputerAlgebra/Cash/Date.hs b/src/Math/ComputerAlgebra/Cash/Date.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/Date.hs @@ -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" diff --git a/src/Math/ComputerAlgebra/Cash/HS2SCSCP.hs b/src/Math/ComputerAlgebra/Cash/HS2SCSCP.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/HS2SCSCP.hs @@ -0,0 +1,214 @@ +-- Time-stamp: +-- +-- 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 "" 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 = "" +-- then the options. we assume call_ID to be always present. +scscpInfix = "" +-- then the OMS indicating the type, then the included data, which can +-- be OMA, OME, OMR, or any other result type +scscpSuffix = "" + +----------------------------------------------------------------------------- +-- 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 + ++ "" + ++ "" + ++ (if null ref + then concatMap writeOMObj args + else ref) + ++ "" + ++ 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 = "" -- 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 + ++ "" + ++ "" ++ errText err ++ "" + ++ "" + ++ scscpSuffix +writeSCSCPMsg (PResult res id t mem) + = scscpPrefix + ++ writeInfos id t mem + ++ scscpInfix + ++ "" + ++ 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) ' ' + ++ "':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 + diff --git a/src/Math/ComputerAlgebra/Cash/HS_SCSCP.lhs b/src/Math/ComputerAlgebra/Cash/HS_SCSCP.lhs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/HS_SCSCP.lhs @@ -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" = "" -- 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 + +-- +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" + ("" ++ trim listXML ++ "") + -- 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" + ("" ++ trim listXML ++ "") + -- 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" + ("" ++ trim listXML ++ "") + -- 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" + ("" ++ trim listXML ++ "") + -- 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\" />" -- HWL: WAS: "call_ID" + ++ encodeXML callId ++ "" + ++ maybeResOpt ++ + concat (zipWith maybeWriteInt + [nMaxTime,nMinMem,nMaxMem,nDebug] + [maxtime,minmem,maxmem,debug]) + where maybeResOpt = case res of + Nothing -> "" + Just r -> prefix + ++ show (encodeResultOption r) + ++ " />" + maybeWriteInt name value = case value of + Nothing -> "" + Just i -> prefix ++ show name + ++ " />" + ++ writeOMObj + (toOM (i::Int)) + prefix = " 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 + = "" -- HWL: was call_ID + ++ "" ++ id ++ "" + ++ maybeTime ++ maybeMem + where maybeTime = case t of + Nothing -> "" + Just t -> "" + ++ writeOMObj (toOM t) + maybeMem = case mem of + Nothing -> "" + Just m -> "" + ++ 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} + + + + + + call_identifier + + runtime_limit_in_milliseconds + + minimal_memory_required_in_bytes + + memory_limit_in_bytes + + debuglevel_value + + + + + + + + + + + + + + + + + +\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} + + + + + + call_identifier + + runtime_in_milliseconds + + used_memory_in_bytes + + + + + + + + + +\end{xcode} + +And for referenced data (stored in CA), the following (called a cookie): +\begin{xcode} + + + + + call_identifier + + + + + + + +\end{xcode} + +\item Procedure Terminated (\cd{PTerminated}) +\begin{xcode} + + + + + + call_identifier + + runtime_in_milliseconds + + used_memory_in_bytes + + + + + + + + + Error_message + + + + +\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: + + +Client -> Server: + + +Server -> Client: + +\end{xcode} +\begin{xcode} +Server -> Client: + + +Client -> Server: + + +Server -> Client: + + +OR JUST: +\end{xcode} + +The actual data messages are enclosed in processing instruction blocks: +\begin{xcode} + +... message (OpenMath object), formats see above... + +\end{xcode} +The exception is the interrupt signal, which is just SIGUSR2 to the server. + +Messages can be canceled using \verb!! to close the block. +The server should not process the message. + +Sessions are terminated using \verb!!, 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 = " 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) +{- + + + + + +-- libkant 4.0 uses these as well: + + +-} +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!()!. 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} diff --git a/src/Math/ComputerAlgebra/Cash/Monitor.hs b/src/Math/ComputerAlgebra/Cash/Monitor.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/Monitor.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE ForeignFunctionInterface #-} +---------------------------------------------------------------------------- +-- (c) 2010 +-- Hans-Wolfgang Loidl +-- code clean-up and port to ghc-6.12.2 +-- +-- (c) 2008 +-- Jost Berthold +-- introduced more accurate types and included header file +-- +-- +-- (c) 2006 +-- Abdallah Al Zain +-- +-- 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 diff --git a/src/Math/ComputerAlgebra/Cash/SCSCP_API.hs b/src/Math/ComputerAlgebra/Cash/SCSCP_API.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/SCSCP_API.hs @@ -0,0 +1,433 @@ +{-# OPTIONS -cpp -XScopedTypeVariables -XPatternSignatures #-} +{- +Time-stamp: + +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: + + +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: + + +where CLIENTVERSION *should* be one of the supported versions + announced by the server in list D + +then server sends: + + +where SERVERVERSION confirms the CLIENTVERSION (same string) + If the CLIENTVERSION is not supported, the server may + terminate the session by sending + instead + +Then server and client communicate in sequences of OMOBJ messages, +separated by + + ...OMOBJ... + + +For canceling a started message, + + may terminate the transaction at any time in-between + 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 " 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 " -- 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 " 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]) + diff --git a/src/Math/ComputerAlgebra/Cash/SCSCP_DTD.hs b/src/Math/ComputerAlgebra/Cash/SCSCP_DTD.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/SCSCP_DTD.hs @@ -0,0 +1,245 @@ +{- +-- Time-stamp: + +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++" ...>..." +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 "" "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 "" "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 "" "OME" ca)) + (definite fromElem "" "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-} diff --git a/src/Math/ComputerAlgebra/Cash/SGPTypes.hs b/src/Math/ComputerAlgebra/Cash/SGPTypes.hs new file mode 100644 --- /dev/null +++ b/src/Math/ComputerAlgebra/Cash/SGPTypes.hs @@ -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)