From a1d221a2cbce64c81e5ab498af06215999c0a805 Mon Sep 17 00:00:00 2001 From: dnt Date: Tue, 26 Nov 1996 15:45:25 +0000 Subject: [PATCH] [project @ 1996-11-26 15:44:35 by dnt] Merged in changes from new-build-system branch --- GHC_ONLY/bugs/sanders_array/Main-ORIG.hs | 47 - GHC_ONLY/cg015/Main2.hs | 25 - GHC_ONLY/cg015/Main3.hs | 18 - GHC_ONLY/cg015/Main4.hs | 17 - Jmakefile | 51 - Makefile | 39 + imaginary/primes/Main2.hs | 15 - mk/nofib.mk | 116 ++ mk/site.mk | 63 + real/Makefile | 7 + real/anna/Main.hs | 61 +- real/anna/Makefile | 17 + real/bspt/Makefile | 9 + real/fulsom/Fulsom.hi | 4 - real/parser/Main-GHC.hs | 1452 ---------------------- real/reptile/Main-ALT.hs | 34 - spectral/compreals/makefile | 0 spectral/hartel/fft/Main2.hs | 412 ------ spectral/hartel/wave4main/Main2.hs | 597 --------- 19 files changed, 252 insertions(+), 2732 deletions(-) delete mode 100644 GHC_ONLY/bugs/sanders_array/Main-ORIG.hs delete mode 100644 GHC_ONLY/cg015/Main2.hs delete mode 100644 GHC_ONLY/cg015/Main3.hs delete mode 100644 GHC_ONLY/cg015/Main4.hs delete mode 100644 Jmakefile create mode 100644 Makefile delete mode 100644 imaginary/primes/Main2.hs create mode 100644 mk/nofib.mk create mode 100644 mk/site.mk create mode 100644 real/Makefile create mode 100644 real/anna/Makefile create mode 100644 real/bspt/Makefile delete mode 100644 real/fulsom/Fulsom.hi delete mode 100644 real/parser/Main-GHC.hs delete mode 100644 real/reptile/Main-ALT.hs delete mode 100644 spectral/compreals/makefile delete mode 100644 spectral/hartel/fft/Main2.hs delete mode 100644 spectral/hartel/wave4main/Main2.hs diff --git a/GHC_ONLY/bugs/sanders_array/Main-ORIG.hs b/GHC_ONLY/bugs/sanders_array/Main-ORIG.hs deleted file mode 100644 index 3af098f..0000000 --- a/GHC_ONLY/bugs/sanders_array/Main-ORIG.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- -From: Paul Sanders -To: partain -Subject: A puzzle for you -Date: Mon, 28 Oct 91 17:02:19 GMT - -I'm struggling with the following code fragment at the moment: --} - -conv_list :: [a] -> [b] -> [[c]] -> Array (a,b) c -> Array (a,b) c -conv_list [] _ _ ar = ar -conv_list _ _ [] ar = ar -conv_list (r:rs) cls (rt:rts) ar - = conv_list rs cls rts ar' - where ar' = conv_elems r cls rt ar - -conv_elems :: a -> [b] -> [c] -> Array (a,b) c -> Array (a,b) c -conv_elems row [] _ ar = ar -conv_elems _ _ [] ar = ar -conv_elems row (col:cls) (rt:rts) ar - = conv_elems row cls rts ar' - where ar' = ar // ((row,col) := rt) - -ar_list = [[1,2,3], - [6,7,8], - [10,12,15]] - -ar :: Array (Int, Int) Int -ar = conv_list [1..3] [1..3] ar_list init_ar - where init_ar = array ((1,1),(3,3)) [] - -main = appendChan stdout (show ar) abort done - -{- -What it tries to do is turn a list of lists into a 2-d array in an incremental -fashion using 2 nested for-loops. It compiles okay on the prototype compiler -but gives a segmentation fault when it executes. I know I can define in the -array in one go (and I have done) but, for my piece of mind, I want to get this -way working properly. - -Is it a bug in the prototype or is there a glaringly obvious error in my code -which I've been stupid to spot ???? - -Hoping its the latter, - -Paul. --} diff --git a/GHC_ONLY/cg015/Main2.hs b/GHC_ONLY/cg015/Main2.hs deleted file mode 100644 index 470d68a..0000000 --- a/GHC_ONLY/cg015/Main2.hs +++ /dev/null @@ -1,25 +0,0 @@ -import GlasgowIOMonad -import GlasgowIO - -data CList = CNil | CCons Int CList - -mk :: Int -> CList -mk n = if (n == 0) then - CNil - else - CCons 1 (mk (n - 1)) - -clen :: CList -> Int -clen CNil = 0 -clen (CCons _ cl) = 1 + (clen cl) - -main = case (clen list4) of - len4 -> - case (len4 `plusInt` len4) of - 8 -> finish 65# -- 'A' - _ -> finish 66# -- 'B' - where - list4 = mk 4 - -finish :: IntPrim -> IO () -finish n = ccall putchar n `thenIOPrim_` returnIO () diff --git a/GHC_ONLY/cg015/Main3.hs b/GHC_ONLY/cg015/Main3.hs deleted file mode 100644 index 06d89b2..0000000 --- a/GHC_ONLY/cg015/Main3.hs +++ /dev/null @@ -1,18 +0,0 @@ -import GlasgowIOMonad -import GlasgowIO - -main = if foo == (1::Int) then - finish 65# -- 'A' - else - finish 66# -- 'B' - where - foo = f (f 3) - - f = if ((3::Int) > (4::Int)) then inc else dec - - inc, dec :: Int -> Int - inc x = x+1 - dec x = x-1 - -finish :: IntPrim -> IO () -finish n = ccall putchar n `thenIOPrim_` returnIO () diff --git a/GHC_ONLY/cg015/Main4.hs b/GHC_ONLY/cg015/Main4.hs deleted file mode 100644 index c144bdd..0000000 --- a/GHC_ONLY/cg015/Main4.hs +++ /dev/null @@ -1,17 +0,0 @@ -import GlasgowIOMonad -import GlasgowIO - -main = if foo == (16::Int) then - finish 65# -- 'A' - else - finish 66# -- 'B' - where - foo = twice twice twice inc 0 - - twice f x = f (f x) - - inc :: Int -> Int - inc x = x+1 - -finish :: IntPrim -> IO () -finish n = ccall putchar n `thenIOPrim_` returnIO () diff --git a/Jmakefile b/Jmakefile deleted file mode 100644 index 11fc941..0000000 --- a/Jmakefile +++ /dev/null @@ -1,51 +0,0 @@ -#define IHaveSubdirs - -#if IncludeRealNoFibTests == YES -#define _RealTests real -#else -#define _RealTests /*none*/ -#endif - -#if IncludeSpectralNoFibTests == YES -#define _SpectralTests spectral -#else -#define _SpectralTests /*none*/ -#endif - -#if IncludeImaginaryNoFibTests == YES -#define _ImaginaryTests imaginary -#else -#define _ImaginaryTests /*none*/ -#endif - -#if IncludePENDINGNoFibTests == YES -#define _PENDINGTests PENDING -#else -#define _PENDINGTests /*none*/ -#endif - -#if IncludeUNUSEDNoFibTests == YES -#define _UNUSEDTests UNUSED -#else -#define _UNUSEDTests /*none*/ -#endif - -#if IncludeGHC_ONLYNoFibTests == YES -#define _GHC_ONLYTests GHC_ONLY -#else -#define _GHC_ONLYTests /*none*/ -#endif - -#if IncludePRIVATENoFibTests == YES -#define _PRIVATETests PRIVATE -#else -#define _PRIVATETests /*none*/ -#endif - -#if IncludeParallelNoFibTests == YES -#define _ParallelTests parallel -#else -#define _ParallelTests /*none*/ -#endif - -SUBDIRS = _GHC_ONLYTests _PRIVATETests _ParallelTests _PENDINGTests _UNUSEDTests _ImaginaryTests _SpectralTests _RealTests diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..1257885 --- /dev/null +++ b/Makefile @@ -0,0 +1,39 @@ +# $Id: Makefile,v 1.2 1996/11/26 15:44:36 dnt Exp $ + +TOP = .. + +SUBDIRS = + +ifeq ($(IncludeImaginaryNoFibTests), YES) + SUBDIRS += imaginary +endif + +ifeq ($(IncludeSpectralNoFibTests), YES) + SUBDIRS += spectral +endif + +ifeq ($(IncludeRealNoFibTests), YES) + SUBDIRS += real +endif + +ifeq ($(IncludePENDINGNoFibTests), YES) + SUBDIRS += PENDING +endif + +ifeq ($(IncludeUNUSEDNoFibTests), YES) + SUBDIRS += UNUSED +endif + +ifeq ($(IncludeGHC_ONLYNoFibTests), YES) + SUBDIRS += GHC_ONLY +endif + +ifeq ($(IncludePRIVATENoFibTests), YES) + SUBDIRS += PRIVATE +endif + +ifeq ($(IncludeParallelNoFibTests), YES) + SUBDIRS += parallel +endif + +include $(TOP)/nofib/mk/nofib.mk diff --git a/imaginary/primes/Main2.hs b/imaginary/primes/Main2.hs deleted file mode 100644 index dbd37f2..0000000 --- a/imaginary/primes/Main2.hs +++ /dev/null @@ -1,15 +0,0 @@ -succ :: Int -> Int -succ x = x + 1 - -isdivs :: Int -> Int -> Bool -isdivs n x = mod x n /= 0 - -the_filter :: [Int] -> [Int] -the_filter (n:ns) = filter (isdivs n) ns - -main = let - primes :: [Int] - primes = map head (iterate the_filter (iterate succ 2)) - in - print (primes !! 1500) ---OLD: main = print (take 300 primes) diff --git a/mk/nofib.mk b/mk/nofib.mk new file mode 100644 index 0000000..647e9c4 --- /dev/null +++ b/mk/nofib.mk @@ -0,0 +1,116 @@ + +include $(TOP)/nofib/mk/site.mk + +#----------------------------------------------------------------------------- +# General utilities + +SHELL = /bin/sh +RM = rm -f +TIME = time +STRIP = strip +SIZE = size + +#----------------------------------------------------------------------------- +# Haskell utilities + +ifdef UseInstalledUtils + RUNSTDTEST = runstdtest +else + RUNSTDTEST = $(TOP)/glafp-utils/runstdtest/runstdtest +endif + +#----------------------------------------------------------------------------- +# The 'all' target prints out the corrent configuration and builds runtests. + +all :: + @echo HC = $(HC) + @echo HCFLAGS = $(HCFLAGS) + @echo RUNTESTFLAGS = $(RUNTESTFLAGS) + +print_% :: + @echo HCFLAGS_$* = $(HCFLAGS_$*) + +all :: $(foreach way,$(WAYS),print_$(way)) runtests + +#----------------------------------------------------------------------------- +# Subdirs stuff. + +ifdef SUBDIRS + clean:: + @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i $(MFLAGS) clean; \ + done + veryclean:: + @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i $(MFLAGS) veryclean; \ + done + runtests:: + @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ + for i in $(SUBDIRS) ; do \ + $(MAKE) -C $$i $(MFLAGS) runtests; \ + done +endif + +#----------------------------------------------------------------------------- +# Cleaning things. + +clean :: + $(RM) *.CKP *.ln *.BAK *.bak *.o core a.out ,* *.a .emacs_* *.hi + $(RM) tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi + $(RM) *.log *.toc *.lot *.lof *.blg *.info *.itxi *.itex *.cb errs + +veryclean :: + $(RM) .??*~ *~ *.orig *.rej + +#----------------------------------------------------------------------------- +# Nofib program targets. + +ifdef PROG + +ifndef SRCS + SRCS = Main.hs +endif + +OBJS = $(patsubst %.lhs, %.o, $(patsubst %.hs, %.o, $(SRCS))) + +define COMPILE + @echo === compiling $(PROG)/$@ $(EXTRA_HCFLAGS) === + @$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ -c $< \ + $(HCFLAGS_$(patsubst .%,%,$(suffix $(basename $@)))) + @echo === size of $(PROG)/$@ === + @$(SIZE) $@ +endef + +%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \ +%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \ +%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.hs + $(COMPILE) + +%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \ +%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \ +%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.lhs + $(COMPILE) + +$(PROG)_% : $(OBJS:.o=.%.o) + @echo === linking $@ $(EXTRA_HCFLAGS) === + @$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ $^ $(LIBS) + @$(STRIP) $@ + @echo === size of $@ === + @$(SIZE) $@ + +runtest_% : $(PROG)_% + @echo === running $< $(EXTRA_RUNTESTFLAGS) === + @$(TIME) $(RUNSTDTEST) ./$< \ + $(addprefix -i ,$(wildcard $(PROG).stdin)) \ + $(addprefix -o1 ,$(wildcard $(PROG).stdout)) \ + $(addprefix -o2 ,$(wildcard $(PROG).stderr)) \ + $(RUNTESTFLAGS) $(EXTRA_RUNTESTFLAGS) + +runtests :: $(foreach way,$(WAYS),$(PROG)_$(way) runtest_$(way)) + +clean :: + $(RM) $(foreach way,$(WAYS),$(PROG)_$(way)) + +endif diff --git a/mk/site.mk b/mk/site.mk new file mode 100644 index 0000000..8e48bc1 --- /dev/null +++ b/mk/site.mk @@ -0,0 +1,63 @@ +#----------------------------------------------------------------------------- +# $Id: site.mk,v 1.2 1996/11/26 15:44:59 dnt Exp $ + +#----------------------------------------------------------------------------- +# Haskell compiler + +#HC = $(TOP)/ghc/driver/ghc +HC = ghc-2.01 +HCFLAGS = -H32m -K2m + +#----------------------------------------------------------------------------- +# Flags to use when we run a test + +RUNTESTFLAGS = +RTS -H48m -K32m --RTS + +#----------------------------------------------------------------------------- +# Set WAYS according to which ways you want to build the nofib suite + +WAYS = normal + +#WAYS = normal mc mr mt mp mg 2s 1s du p t a b c d e f g h i j k l m n o p A B + +# ================================================================ +# BUILDS stuff: main sequential ones + +HCFLAGS_normal = +HCFLAGS_p = -prof +HCFLAGS_t = +HCFLAGS_u = + +# === builds: concurrent and parallel ============================ + +HCFLAGS_mc = +HCFLAGS_mr = +HCFLAGS_mt = +HCFLAGS_mp = +HCFLAGS_mg = + +# === builds: non-std garbage collectors ========================== + +HCFLAGS_2s = -gc-2s +HCFLAGS_1s = -gc-1s +HCFLAGS_du = -gc-du + +# === builds: "user ways" ======================================= + +HCFLAGS_a = +HCFLAGS_b = +HCFLAGS_c = +HCFLAGS_d = +HCFLAGS_e = +HCFLAGS_f = +HCFLAGS_g = +HCFLAGS_h = +HCFLAGS_i = +HCFLAGS_j = +HCFLAGS_k = +HCFLAGS_l = +HCFLAGS_m = +HCFLAGS_n = +HCFLAGS_o = +HCFLAGS_A = +HCFLAGS_B = diff --git a/real/Makefile b/real/Makefile new file mode 100644 index 0000000..94cd7a4 --- /dev/null +++ b/real/Makefile @@ -0,0 +1,7 @@ +TOP = ../.. + +SUBDIRS = anna bspt compress compress2 ebnf2ps fluid fulsom gamteb gg \ + grep hidden HMMS hpg infer lift maillist mkhprog parser pic prolog \ + reptile rsa symalg veritas + +include $(TOP)/nofib/mk/nofib.mk diff --git a/real/anna/Main.hs b/real/anna/Main.hs index b5267d0..f331f32 100644 --- a/real/anna/Main.hs +++ b/real/anna/Main.hs @@ -149,29 +149,6 @@ maStrictAn table flagsInit fileName fullEnvAug = fullEnv ++ map2nd deScheme maBaseTypes deScheme (Scheme _ texpr) = texpr -{- ---==========================================================-- --- -anna :: [Flag] -> String -> Dialogue - -anna flags name - = getEnv "ANNADIR" noANNADIR (\anna_dir -> - readFile (anna_dir++"/anna_table") noTable (\tablestr -> - let table = rtReadTable tablestr in - readFile (name++".cor") noFile (\str -> - let result = maStrictAn table flags str in - appendChan stdout result writeFails done))) - where - noANNADIR err = abandon "ANNADIR not defined" - noTable err = abandon "Cannot find $ANNADIR/table" - noFile err = abandon ("Can't open "++name++".cor") - writeFails (WriteError s) = abandon s - abandon s = appendChan stdout s abort done - getEnv envvar fail succ = succ "/home/r62/users/sewardj/Bin" - twords n = "\nRead " ++ show n ++ " lattice sizes.\n" --} - - --==========================================================-- -- --main :: [Response] -> [Request] @@ -182,47 +159,11 @@ main = do raw_args <- getArgs let cmd_line_args = maGetFlags raw_args anna_dir <- getEnv "ANNADIR" - tableStr <- readFile (anna_dir++"/anna_table") + tableStr <- readFile (anna_dir ++ "/anna_table") file_contents <- getContents let table = rtReadTable tableStr putStr (maStrictAn table cmd_line_args file_contents) -{- OLD 1.2 -main resps - = [ - GetArgs, - fr 0 (GetEnv "ANNADIR"), - fr 1 (ReadFile ), - fr 2 (ReadChan stdin), - fr 3 (AppendChan stdout ) - ] ++ fr 4 [] (maStrictAn table cmd_line_args file_contents) - where - cmd_line_args = case (resps ## 0) of - StrList ss -> maGetFlags ss - _ -> panic "GetArgs request failed" - - anna_dir = case (mySeq cmd_line_args (resps ## 1)) of - Str s -> s - _ -> myFail "Environment variable \"ANNADIR\" is not set." - - tableStr = case (mySeq anna_dir (resps ## 2)) of - Str s -> s - _ -> myFail ("Can't read " ++ anna_dir ++ "/anna_table") - - file_contents = case (mySeq (head tableStr) (resps ## 3)) of - Str s -> s - _ -> panic "ReadChan request failed" - - --append_res = case (mySeq (head file_contents) (resps ## 4)) of - -- Success -> (42 :: Int) - -- _ -> panic "AppendChan request failed" - - fr n x = case resps ## n of - Success -> x - _ -> x - - table = rtReadTable tableStr --} --==========================================================-- -- diff --git a/real/anna/Makefile b/real/anna/Makefile new file mode 100644 index 0000000..5d7aa5f --- /dev/null +++ b/real/anna/Makefile @@ -0,0 +1,17 @@ +TOP = ../../.. +PROG = anna +SRCS = BaseDefs.hs MyUtils.hs Utils.hs AbstractVals2.hs \ + SuccsAndPreds2.hs AbstractMisc.hs Dependancy.hs \ + MakeDomains.hs Parser2.hs PrettyPrint.hs LambdaLift5.hs \ + TypeCheck5.hs EtaAbstract.hs DomainExpr.hs AbsConc3.hs Apply.hs \ + Inverse.hs BarakiMeet.hs BarakiConc3.hs \ + Constructors.hs TExpr2DExpr.hs AbstractEval2.hs \ + PrintResults.hs Simplify.hs SmallerLattice.hs \ + FrontierMisc2.hs FrontierDATAFN2.hs FrontierGENERIC2.hs \ + StrictAn6.hs ReadTable.hs Main.hs + +EXTRA_RUNTESTFLAGS = \ + -prescript ./anna.prescript -postscript ./anna.postscript \ + -i big.cor -o1 big.sum.out + +include $(TOP)/nofib/mk/nofib.mk diff --git a/real/bspt/Makefile b/real/bspt/Makefile new file mode 100644 index 0000000..4327796 --- /dev/null +++ b/real/bspt/Makefile @@ -0,0 +1,9 @@ +TOP = ../../.. +PROG = bspt + +SRCS = BSPT.lhs Euclid.lhs EuclidGMS.lhs GeomNum.lhs Init.lhs \ + Input.lhs Interface.lhs Interpret.lhs Libfuns.lhs MGRlib.lhs \ + Main.lhs Merge.lhs Params.lhs Prog.lhs Rationals.lhs \ + Render.lhs Stdlib.lhs + +include $(TOP)/nofib/mk/nofib.mk diff --git a/real/fulsom/Fulsom.hi b/real/fulsom/Fulsom.hi deleted file mode 100644 index fbccfbd..0000000 --- a/real/fulsom/Fulsom.hi +++ /dev/null @@ -1,4 +0,0 @@ -interface Fulsom where { -{-# IMPORTING Shapes, Quad, Raster, Oct, Interval, Types #-} -main :: Dialogue {-# ARITY main = 1 #-}{-# STRICTNESS main = "T,T" ST #-} -} diff --git a/real/parser/Main-GHC.hs b/real/parser/Main-GHC.hs deleted file mode 100644 index 4dc53d2..0000000 --- a/real/parser/Main-GHC.hs +++ /dev/null @@ -1,1452 +0,0 @@ - ---==========================================================-- ---=== Raw lexical analysis (tokenisation) of source ===-- ---=== Lexer.hs ===-- ---==========================================================-- - -module Main where - ----------------------------------------------------------- --- Lexemes -- ----------------------------------------------------------- - -type Token = (Int, Int, Lex, String) -- (line, column, lexeme type, value) - -data Lex = Lcon -- constructor used as prefix: - -- normal prefix constructor, - -- or bracketed infix constructor - - | Lconop -- constructor used as infix: - -- normal prefix constructor in backquotes, - -- or infix constructor (starting with ":") - - | Lvar -- variable used as prefix: - -- normal prefix variable, - -- or bracketed infix var (operator) - - | Lvarop -- variable used as infix: - -- normal prefix variable in backquotes, - -- or infix variable (operator) - - --| Ltycon -- constructor starting with A-Z - -- subcase of Lcon - - --| Ltyvar -- variable starting with a-z - -- subcase of Lvar - - | Lintlit -- integer literal - | Lcharlit -- character literal - | Lstringlit -- string literal - - | Llbrace -- { - | Lrbrace -- } - | Lsemi -- ; - | Lequals -- = - | Lbar -- | - | Larrow -- -> - | Llparen -- ( - | Lrparen -- ) - | Lcomma -- , - | Llbrack -- [ - | Lrbrack -- ] - | Lunder -- _ - | Lminus -- - - | Lslash -- \ - - | Lmodule - | Linfixl - | Linfixr - | Linfix - | Lext - | Ldata - | Lif - | Lthen - | Lelse - | Llet - | Lin - | Lcase - | Lof - | Lwhere - - | Leof -#ifndef __GLASGOW_HASKELL__ - deriving (Eq, Text) -#else -instance Eq Lex where - a == b = tag_Lex a == tag_Lex b - where - tag_Lex Lcon = (1::Int) - tag_Lex Lconop = 2 - tag_Lex Lvar = 3 - tag_Lex Lvarop = 4 - tag_Lex Lintlit = 5 - tag_Lex Lcharlit = 6 - tag_Lex Lstringlit = 7 - tag_Lex Llbrace = 8 - tag_Lex Lrbrace = 9 - tag_Lex Lsemi = 10 - tag_Lex Lequals = 11 - tag_Lex Lbar = 12 - tag_Lex Larrow = 13 - tag_Lex Llparen = 14 - tag_Lex Lrparen = 15 - tag_Lex Lcomma = 16 - tag_Lex Llbrack = 17 - tag_Lex Lrbrack = 18 - tag_Lex Lunder =19 - tag_Lex Lminus = 20 - tag_Lex Lslash = 21 - tag_Lex Lmodule = 22 - tag_Lex Linfixl = 23 - tag_Lex Linfixr = 24 - tag_Lex Linfix = 25 - tag_Lex Lext = 26 - tag_Lex Ldata =27 - tag_Lex Lif = 28 - tag_Lex Lthen = 29 - tag_Lex Lelse = 30 - tag_Lex Llet =31 - tag_Lex Lin = 32 - tag_Lex Lcase = 33 - tag_Lex Lof = 34 - tag_Lex Lwhere = 35 - tag_Lex Leof = 36 - - (/=) = dEFAULT_ne -#endif - - -{- - Lexing rules: - - case ( - if next is \, -> Llparen - if next is symbol, take symbols and expect closing ) -> Lvar - if next is :, take tail-ident-chars, expect closing ) -> Lcon - otherwise -> Llparen - - case ` - if next A-Z, take tail-ident-chars, expect ` -> Lconop - if next a-z, take tail-ident-chars, expect ` -> Lvarop - otherwise -> error - - case A-Z - take tail-ident-chars -> Lcon - - case a-z - take tail-ident-chars -> Lvar - - case 0-9 - take 0-9s -> Lintlit - - case ' - expect a lit-char, then ' -> charlit - - case " - expect lit-chars, then " -> stringlit - - case { - case - -> run_comment - otherwise -> Llbrace - - case } -> Lrbrace - - case ) -> Lrparen - - case [ -> Llbrack - case ] -> Lrbrack - - case ; -> Lsemi - case , -> Lcomma - case _ -> Lunder - case - - case - -> line_comment - case > -> Larrow - otherwise -> Lminus - - case # in column 1: this is a preprocessor line - - case :!#$%&*+./<=>?@\^|~ - take symbols, then case resulting - "=" -> Lequals - "|" -> Lbar - "\" -> Lslash - otherwise - if starts with : -> Lconop - else -> lvarop --} - - - ---==========================================================-- --- -leLex :: Int -> Int -> String -> [Token] - -leLex l n [] - = repeat (99997, 99997, Leof, "") - -leLex l n ('(':[]) - = [(l, n, Llparen, ")")] - -leLex l n ('(':c:cs) - | c == ':' - = case leChunk (n+1) leIsTailChar cs of - (restSym, nn, restInput) -> case restInput of - [] -> leFail l nn " ) expected" - (')':as) -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as - (_:_) -> leFail l nn " ) expected" - | c == '\\' - = (l, n, Llparen, "(") : leLex l (n+1) (c:cs) - | leIsSymbol c - = case leChunk (n+1) leIsSymbol cs of - (restSym, nn, restInput) -> case restInput of - [] -> leFail l nn " ) expected" - (')':as) -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as - (_:_) -> leFail l nn " ) expected" - | otherwise - = (l, n, Llparen, "(") : leLex l (n+1) (c:cs) - -leLex l n ('`':c:cs) - | isAlpha c - = case leChunk (n+1) isAlpha cs of - (restSym, nn, restInput) -> case restInput of - [] -> leFail l nn " ` expected" - ('`':as) -> (l, n, if isUpper c then Lconop else Lvarop, c:restSym) - : leLex l (nn+1) as - (_:_) -> leFail l nn " ` expected" - | otherwise - = leFail l n "Bad infix operator" - -leLex l n ('"':cs) - = case leTakeLitChars True l (n+1) cs of - (restSym, nn, restInput) -> case restInput of - [] -> leFail l nn " \" expected" - ('"':as) -> (l, n, Lstringlit, restSym) : leLex l (nn+1) as - (_:_) -> leFail l nn " \" expected" - -leLex l n ('\'':cs) - = case leTakeLitChars False l (n+1) cs of - (restSym, nn, restInput) -> case restInput of - [] -> leFail l nn " ' expected" - ('\'':as) -> case restSym of - [_] -> (l, n, Lcharlit, restSym) : leLex l (nn+1) as - _ -> leFail l (n+1) "Bad character literal" - (_:_) -> leFail l nn " ' expected" - -leLex l n ('}':cs) - = (l, n, Lrbrace, "}") : leLex l (n+1) cs - -leLex l n (')':cs) - = (l, n, Lrparen, ")") : leLex l (n+1) cs - -leLex l n ('[':cs) - = (l, n, Llbrack, "[") : leLex l (n+1) cs - -leLex l n (']':cs) - = (l, n, Lrbrack, "]") : leLex l (n+1) cs - -leLex l n (';':cs) - = (l, n, Lsemi, ";") : leLex l (n+1) cs - -leLex l n (',':cs) - = (l, n, Lcomma, ",") : leLex l (n+1) cs - -leLex l n ('_':cs) - = (l, n, Lunder, "_") : leLex l (n+1) cs - -leLex l n ('{':cs) - = case cs of - [] -> [(l, n, Llbrace, "}")] - ('-':cs2) -> leLexRComment l (n+2) cs2 - (_:_) -> (l, n, Llbrace, "}") : leLex l (n+1) cs - -leLex l n ('-':cs) - = case cs of - [] -> [(l, n, Lminus, "-")] - ('-':cs2) -> leLexLComment l (n+2) cs2 - ('>':cs3) -> (l, n, Larrow, "->") : leLex l (n+2) cs3 - ('}':cs3) -> leFail l n "Misplaced -}" - (_:_) -> (l, n, Lminus, "-") : leLex l (n+1) cs - -leLex l n (' ':cs) - = leLex l (n+1) cs - -leLex l n ('\n':cs) - = leLex (l+1) 1 cs - -leLex l n ('\t':cs) - = leLex l (n - (n `mod` 8) + 9) cs - -leLex l n (c:cs) - = if c == '#' - then if n == 1 - then - {- This is a CPP line number thingy -} - let lineNoText = takeWhile isDigit (tail cs) - lineNo = leStringToInt lineNoText - nextLine = drop 1 (dropWhile ((/=) '\n') cs) - in - leLex lineNo 1 nextLine - else - {- it's a symbol starting with # -} - case leChunk (n+1) leIsSymbol cs of - (restSym, nn, restText) -> (l, n, Lvarop, c:restSym) : - leLex l nn restText - else - if isAlpha c - then case leChunk (n+1) leIsTailChar cs of - (restSym, nn, restText) -> (l, n, if isUpper c - then Lcon - else Lvar, c:restSym) : - leLex l nn restText - else - if isDigit c - then case leChunk (n+1) isDigit cs of - (restSym, nn, restText) -> (l, n, Lintlit, c:restSym) : - leLex l nn restText - else - if leIsSymbol c - then case leChunk (n+1) leIsSymbol cs of - (restSym, nn, restText) -> (l, n, if c == ':' - then Lconop - else Lvarop, c:restSym) : - leLex l nn restText - else - leFail l n ("Illegal character " ++ [c]) - - ---==========================================================-- --- -leChunk :: Int -> (Char -> Bool) -> String -> (String, Int, String) - -leChunk n proper [] - = ([], n, []) - -leChunk n proper (c:cs) - | proper c - = case leChunk (n+1) proper cs of - (restId, col, restInput) -> (c:restId, col, restInput) - | otherwise - = ([], n, c:cs) - - ---==========================================================-- --- -leTakeLitChars :: Bool -> Int -> Int -> String -> (String, Int, String) - -leTakeLitChars d l n [] - = leFail l n "End of file inside literal" - -leTakeLitChars d l n ('\\':'\\':cs) - = case leTakeLitChars d l (n+2) cs of - (rest, col, left) -> ('\\':rest, col, left) - -leTakeLitChars d l n ('\\':'n':cs) - = case leTakeLitChars d l (n+2) cs of - (rest, col, left) -> ('\n':rest, col, left) - -leTakeLitChars d l n ('\\':'t':cs) - = case leTakeLitChars d l (n+2) cs of - (rest, col, left) -> ('\t':rest, col, left) - -leTakeLitChars d l n ('\\':'"':cs) - = case leTakeLitChars d l (n+2) cs of - (rest, col, left) -> ('"':rest, col, left) - -leTakeLitChars d l n ('\\':'\'':cs) - = case leTakeLitChars d l (n+2) cs of - (rest, col, left) -> ('\'':rest, col, left) - -leTakeLitChars d l n ('"':cs) - | d = ([], n, ('"':cs)) - | not d = case leTakeLitChars d l (n+1) cs of - (rest, col, left) -> ('"':rest, col, left) - -leTakeLitChars d l n ('\'':cs) - | not d = ([], n, ('\'':cs)) - | d = case leTakeLitChars d l (n+1) cs of - (rest, col, left) -> ('\'':rest, col, left) - -leTakeLitChars d l n ('\n':cs) - = leFail l n "Literal exceeds line" - -leTakeLitChars d l n ('\t':cs) - = leFail l n "Literal contains tab" - -leTakeLitChars d l n (c:cs) - = case leTakeLitChars d l (n+1) cs of - (rest, col, left) -> (c:rest, col, left) - - ---==========================================================-- --- -leLexLComment :: Int -> Int -> String -> [Token] - -leLexLComment l n cs - = leLex (l+1) 1 (drop 1 (dropWhile ((/=) '\n') cs)) - - ---==========================================================-- --- -leLexRComment :: Int -> Int -> String -> [Token] - -leLexRComment l n [] - = leFail l n "End of file inside {- ... -} comment" - -leLexRComment l n ('-':'}':cs) - = leLex l (n+2) cs - -leLexRComment l n ('\n':cs) - = leLexRComment (l+1) 1 cs - -leLexRComment l n ('\t':cs) - = leLexRComment l (n - (n `mod` 8) + 9) cs - -leLexRComment l n (c:cs) - = leLexRComment l (n+1) cs - - ---==========================================================-- --- -leIsSymbol :: Char -> Bool - -leIsSymbol c = c `elem` leSymbols - -leSymbols = ":!#$%&*+./<=>?\\@^|~" - - ---==========================================================-- --- -leIsTailChar :: Char -> Bool - -leIsTailChar c - = isLower c || - isUpper c || - isDigit c || - c == '\'' || - c == '_' || - c == '\'' - - ---==========================================================-- --- -leIsLitChar :: Char -> Bool - -leIsLitChar c - = c /= '\n' && - c /= '\t' && - c /= '\'' && - c /= '"' - - ---==========================================================-- --- -leStringToInt :: String -> Int - -leStringToInt - = let s2i [] = 0 - s2i (d:ds) = (fromEnum d - fromEnum '0') + 10 *s2i ds - in s2i . reverse - - ---==========================================================-- --- -leFail l n m - = fail ("Lexical error, line " ++ show l ++ ", col " ++ show n ++ - ":\n " ++ m ) - -fail m = error ( "\n\n" ++ m ++ "\n" ) - ---==========================================================-- ---=== end Lexer.hs ===-- ---==========================================================-- - ---==========================================================-- ---=== Keyword spotting, and offside rule implementation ===-- ---=== Layout.hs ===-- ---==========================================================-- - ---module Layout - ---==========================================================-- --- -laKeyword :: Token -> Token - -laKeyword (l, n, what, text) - = let - f Lvarop "=" = Lequals - f Lvarop "|" = Lbar - f Lvarop "\\" = Lslash - - f Lvar "module" = Lmodule - f Lvar "infix" = Linfix - f Lvar "infixl" = Linfixl - f Lvar "infixr" = Linfixr - f Lvar "ext" = Lext - f Lvar "data" = Ldata - f Lvar "if" = Lif - f Lvar "then" = Lthen - f Lvar "else" = Lelse - f Lvar "let" = Llet - f Lvar "in" = Lin - f Lvar "case" = Lcase - f Lvar "of" = Lof - f Lvar "where" = Lwhere - - f item words = item - - in - (l, n, f what text, text) - - ---==========================================================-- --- -laLayout :: Int -> [Int] -> [Token] -> [Token] - -laLayout l s [] - = laRbrace (length s - 1) 99999 99999 - -laLayout l s (t1:[]) - = t1 : laRbrace (length s - 1) 99998 99998 - -laLayout l (s:ss) (t1@(l1, n1, w1, c1) : - t2@(l2, n2, w2, c2) : ts) - - | w1 `elem` [Lof, Llet, Lwhere] && w2 /= Llbrace - = t1 : - (l1, n1, Llbrace, "{") : - t2 : - laLayout l2 (n2:s:ss) ts - - | l1 == l - = t1 : - laLayout l (s:ss) (t2:ts) - - | n1 > s - = t1 : - laLayout l1 (s:ss) (t2:ts) - - | n1 == s - = (l1, n1, Lsemi, ";") : - t1 : - laLayout l1 (s:ss) (t2:ts) - - | n1 < s - = (l1, n1, Lrbrace, "}") : - laLayout l ss (t1:t2:ts) - - ---==========================================================-- --- -laRbrace c l n - = take c (repeat (l, n, Lrbrace, "}")) - ---==========================================================-- --- -laMain :: String -> [Token] - -laMain - = laLayout 1 [0] . map laKeyword . leLex 1 1 - - ---==========================================================-- ---=== end Layout.hs ===-- ---==========================================================-- - ---==========================================================-- ---=== Abstract syntax for modules ===-- ---=== AbsSyntax.hs ===-- ---==========================================================-- - ---module AbsSyntax where - ---1.3:data Maybe a = Nothing --- | Just a - -type AList a b = [(a, b)] - -type Id = String - -data Module - = MkModule Id [TopDecl] --- deriving (Text) - -data FixityDecl - = MkFixDecl Id (Fixity, Int) --- deriving (Text) - -data DataDecl - = MkDataDecl Id ([Id], [ConstrAltDecl]) --- deriving (Text) - -data TopDecl - = MkTopF FixityDecl - | MkTopD DataDecl - | MkTopV ValBind --- deriving (Text) - -data Fixity - = InfixL - | InfixR - | InfixN -#ifndef __GLASGOW_HASKELL__ - deriving (Eq,Text) -#else -instance Eq Fixity where - InfixL == InfixL = True - InfixR == InfixR = True - InfixN == InfixN = True - a == b = False - - (/=) = dEFAULT_ne -#endif - - -type ConstrAltDecl - = (Id, [TypeExpr]) - -data TypeExpr = TypeVar Id - | TypeArr TypeExpr TypeExpr - | TypeCon Id [TypeExpr] - | TypeList TypeExpr - | TypeTuple [TypeExpr] --- deriving (Text) - -data ValBind - = MkValBind Int Lhs Expr --- deriving (Text) - -data Lhs - = LhsPat Pat - | LhsVar Id [Pat] --- deriving (Text) - -data Pat - = PatVar Id - | PatCon Id [Pat] - | PatWild - | PatList [Pat] - | PatTuple [Pat] --- deriving (Text) - -data Expr - = ExprVar Id - | ExprCon Id - | ExprApp Expr Expr - | ExprLam [Pat] Expr - | ExprCase Expr [ExprCaseAlt] - | ExprLetrec [ValBind] Expr - | ExprWhere Expr [ValBind] - | ExprGuards [(Expr, Expr)] - | ExprLiteral Literal - | ExprList [Expr] - | ExprTuple [Expr] - | ExprIf Expr Expr Expr - | ExprBar - | ExprFail --- deriving (Text) - -data ExprCaseAlt - = MkExprCaseAlt Pat Expr --- deriving (Text) - -data Literal - = LiteralInt Int - | LiteralChar Char - | LiteralString String --- deriving (Text) - ---==========================================================-- ---=== end AbsSyntax.hs ===-- ---==========================================================-- - ---==========================================================-- ---=== Parser generics ===-- ---=== ParserGeneric.hs ===-- ---==========================================================-- - ---module ParserGeneric - -type PEnv = AList String (Fixity, Int) - -data PResult a = POk PEnv [Token] a - | PFail Token - -type Parser a = PEnv -> [Token] -> PResult a - -type PEntry = (Bool, Expr, Id) - ---==========================================================-- --- -pgItem :: Lex -> Parser String - -pgItem x env [] = PFail pgEOF - -pgItem x env ((l, n, w, t):toks) - | x == w = POk env toks t - | otherwise = PFail (l, n, w, t) - - ---==========================================================-- --- -pgAlts :: [Parser a] -> Parser a - -pgAlts ps env toks - = let - useAlts [] bestErrTok - = PFail bestErrTok - useAlts (p:ps) bestErrTok - = case p env toks of - PFail someErrTok -> useAlts ps (further someErrTok bestErrTok) - successful_parse -> successful_parse - further x1@(l1, n1, w1, t1) x2@(l2, n2, w2, t2) - = if l2 > l1 then x2 - else if l1 > l2 then x1 - else if n1 > n2 then x1 - else x2 - in - useAlts ps (head (toks ++ [pgEOF])) - - ---==========================================================-- --- -pgThen2 :: (a -> b -> c) -> - Parser a -> - Parser b -> - Parser c - -pgThen2 combine p1 p2 env toks - = case p1 env toks of - { - PFail tok1 - -> PFail tok1 ; - POk env1 toks1 item1 - -> case p2 env1 toks1 of - { - PFail tok2 - -> PFail tok2 ; - POk env2 toks2 item2 - -> POk env2 toks2 (combine item1 item2) - } - } - - ---==========================================================-- --- -pgThen3 :: (a -> b -> c -> d) -> - Parser a -> - Parser b -> - Parser c -> - Parser d - -pgThen3 combine p1 p2 p3 env toks - = case p1 env toks of - { - PFail tok1 - -> PFail tok1 ; - POk env1 toks1 item1 - -> case p2 env1 toks1 of - { - PFail tok2 - -> PFail tok2 ; - POk env2 toks2 item2 - -> case p3 env2 toks2 of - { - PFail tok3 - -> PFail tok3 ; - POk env3 toks3 item3 - -> POk env3 toks3 (combine item1 item2 item3) - } - } - } - - ---==========================================================-- --- -pgThen4 :: (a -> b -> c -> d -> e) -> - Parser a -> - Parser b -> - Parser c -> - Parser d -> - Parser e - -pgThen4 combine p1 p2 p3 p4 env toks - = case p1 env toks of - { - PFail tok1 - -> PFail tok1 ; - POk env1 toks1 item1 - -> case p2 env1 toks1 of - { - PFail tok2 - -> PFail tok2 ; - POk env2 toks2 item2 - -> case p3 env2 toks2 of - { - PFail tok3 - -> PFail tok3 ; - POk env3 toks3 item3 - -> case p4 env3 toks3 of - { - PFail tok4 - -> PFail tok4 ; - POk env4 toks4 item4 - -> POk env4 toks4 (combine item1 item2 item3 item4) - } - } - } - } - - ---==========================================================-- --- -pgZeroOrMore :: Parser a -> Parser [a] - -pgZeroOrMore p env toks - = case p env toks of - { - PFail tok1 - -> POk env toks [] ; - POk env1 toks1 item1 - -> case pgZeroOrMore p env1 toks1 of - { - PFail tok2 - -> POk env1 toks1 [item1] ; - POk env2 toks2 item2_list - -> POk env2 toks2 (item1 : item2_list) - } - } - - ---==========================================================-- --- -pgOneOrMore :: Parser a -> Parser [a] - -pgOneOrMore p - = pgThen2 (:) p (pgZeroOrMore p) - - ---==========================================================-- --- -pgApply :: (a -> b) -> Parser a -> Parser b - -pgApply f p env toks - = case p env toks of - { - PFail tok1 - -> PFail tok1 ; - POk env1 toks1 item1 - -> POk env1 toks1 (f item1) - } - - ---==========================================================-- --- -pgTwoOrMoreWithSep :: Parser a -> Parser b -> Parser [a] - -pgTwoOrMoreWithSep p psep - = pgThen4 - (\i1 s1 i2 rest -> i1:i2:rest) - p - psep - p - (pgZeroOrMore (pgThen2 (\sep x -> x) psep p)) - - ---==========================================================-- --- -pgOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a] - -pgOneOrMoreWithSep p psep - = pgThen2 (:) p (pgZeroOrMore (pgThen2 (\sep x -> x) psep p)) - - ---==========================================================-- --- -pgZeroOrMoreWithSep :: Parser a -> Parser b -> Parser [a] - -pgZeroOrMoreWithSep p psep - = pgAlts - [ - pgOneOrMoreWithSep p psep, - pgApply (\x -> x:[]) p, - pgEmpty [] - ] - - ---==========================================================-- --- -pgOptional :: Parser a -> Parser (Maybe a) - -pgOptional p env toks - = case p env toks of - { - PFail tok1 - -> POk env toks Nothing ; - POk env2 toks2 item2 - -> POk env2 toks2 (Just item2) - } - - ---==========================================================-- --- -pgGetLineNumber :: Parser a -> Parser (Int, a) - -pgGetLineNumber p env toks - = let - lineNo = case (head (toks ++ [pgEOF])) of (l, n, w, t) -> l - in - case p env toks of - { - PFail tok1 - -> PFail tok1 ; - POk env2 toks2 item2 - -> POk env2 toks2 (lineNo, item2) - } - - ---==========================================================-- --- -pgEmpty :: a -> Parser a - -pgEmpty item env toks - = POk env toks item - - ---==========================================================-- --- -pgEOF :: Token - -pgEOF = (88888, 88888, Lvar, "*** Unexpected end of source! ***") - - ---============================================================-- ---=== Some kludgey stuff for implementing the offside rule ===-- ---============================================================-- - ---==========================================================-- --- -pgEatEnd :: Parser () - -pgEatEnd env [] - = POk env [] () - -pgEatEnd env (tok@(l, n, w, t):toks) - | w == Lsemi || w == Lrbrace = POk env toks () - | otherwise = POk env (tok:toks) () - - ---==========================================================-- --- -pgDeclList :: Parser a -> Parser [a] - -pgDeclList p - = pgThen3 (\a b c -> b) (pgItem Llbrace) - (pgOneOrMoreWithSep p (pgItem Lsemi)) - pgEatEnd - - ---==========================================================-- ---=== end ParserGeneric.hs ===-- ---==========================================================-- - ---==========================================================-- ---=== The parser. ===-- ---=== Parser.hs ===-- ---==========================================================-- - ---module Parser where - -{- FIX THESE UP -} -utLookupDef env k def - = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] ) -panic = error -{- END FIXUPS -} - -paLiteral :: Parser Literal -paLiteral - = pgAlts - [ - pgApply (LiteralInt.leStringToInt) (pgItem Lintlit), - pgApply (LiteralChar.head) (pgItem Lcharlit), - pgApply LiteralString (pgItem Lstringlit) - ] - -paExpr - = pgAlts - [ - paCaseExpr, - paLetExpr, - paLamExpr, - paIfExpr, - paUnaryMinusExpr, - hsDoExpr [] - ] - -paUnaryMinusExpr - = pgThen2 - (\minus (_, aexpr, _) -> - ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr) - paMinus - paAExpr - -paCaseExpr - = pgThen4 - (\casee expr off alts -> ExprCase expr alts) - (pgItem Lcase) - paExpr - (pgItem Lof) - (pgDeclList paAlt) - -paAlt - = pgAlts - [ - pgThen4 - (\pat arrow expr wheres - -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres)) - paPat - (pgItem Larrow) - paExpr - (pgOptional paWhereClause), - pgThen3 - (\pat agrdrhss wheres - -> MkExprCaseAlt pat - (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres)) - paPat - (pgOneOrMore paGalt) - (pgOptional paWhereClause) - ] - -paGalt - = pgThen4 - (\bar guard arrow expr -> (guard, expr)) - (pgItem Lbar) - paExpr - (pgItem Larrow) - paExpr - -paLamExpr - = pgThen4 - (\lam patterns arrow rhs -> ExprLam patterns rhs) - (pgItem Lslash) - (pgZeroOrMore paAPat) - (pgItem Larrow) - paExpr - -paLetExpr - = pgThen4 - (\lett decls inn rhs -> ExprLetrec decls rhs) - (pgItem Llet) - paValdefs - (pgItem Lin) - paExpr - -paValdefs - = pgApply pa_MergeValdefs (pgDeclList paValdef) - -pa_MergeValdefs - = id - -paLhs - = pgAlts - [ - pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat), - pgApply LhsPat paPat - ] - -paValdef - = pgAlts - [ - pgThen4 - (\(line, lhs) eq rhs wheres - -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres)) - (pgGetLineNumber paLhs) - (pgItem Lequals) - paExpr - (pgOptional paWhereClause), - pgThen3 - (\(line, lhs) grdrhss wheres - -> MkValBind line lhs - (pa_MakeWhereExpr (ExprGuards grdrhss) wheres)) - (pgGetLineNumber paLhs) - (pgOneOrMore paGrhs) - (pgOptional paWhereClause) - ] - -pa_MakeWhereExpr expr Nothing - = expr -pa_MakeWhereExpr expr (Just whereClauses) - = ExprWhere expr whereClauses - -paWhereClause - = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs -paGrhs - = pgThen4 - (\bar guard equals expr -> (guard, expr)) - (pgItem Lbar) - paExpr - (pgItem Lequals) - paExpr - - -paAPat - = pgAlts - [ - pgApply PatVar paVar, - pgApply (\id -> PatCon id []) paCon, - pgApply (const PatWild) (pgItem Lunder), - pgApply PatTuple - (pgThen3 (\l es r -> es) - (pgItem Llparen) - (pgTwoOrMoreWithSep paPat (pgItem Lcomma)) - (pgItem Lrparen)), - pgApply PatList - (pgThen3 (\l es r -> es) - (pgItem Llbrack) - (pgZeroOrMoreWithSep paPat (pgItem Lcomma)) - (pgItem Lrbrack)), - pgThen3 (\l p r -> p) - (pgItem Llparen) - paPat - (pgItem Lrparen) - ] - -paPat - = pgAlts - [ - pgThen2 (\c ps -> PatCon c ps) - paCon - (pgOneOrMore paAPat), - pgThen3 (\ap c pa -> PatCon c [ap,pa]) - paAPat - paConop - paPat, - paAPat - ] - - -paIfExpr - = pgThen4 - (\iff c thenn (t,f) -> ExprIf c t f) - (pgItem Lif) - paExpr - (pgItem Lthen) - (pgThen3 - (\t elsee f -> (t,f)) - paExpr - (pgItem Lelse) - paExpr - ) - -paAExpr - = pgApply (\x -> (False, x, [])) - (pgAlts - [ - pgApply ExprVar paVar, - pgApply ExprCon paCon, - pgApply ExprLiteral paLiteral, - pgApply ExprList paListExpr, - pgApply ExprTuple paTupleExpr, - pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen) - ] - ) - -paListExpr - = pgThen3 (\l es r -> es) - (pgItem Llbrack) - (pgZeroOrMoreWithSep paExpr (pgItem Lcomma)) - (pgItem Lrbrack) - -paTupleExpr - = pgThen3 (\l es r -> es) - (pgItem Llparen) - (pgTwoOrMoreWithSep paExpr (pgItem Lcomma)) - (pgItem Lrparen) - -paVar = pgItem Lvar -paCon = pgItem Lcon -paVarop = pgItem Lvarop -paConop = pgItem Lconop -paMinus = pgItem Lminus - -paOp - = pgAlts [ - pgApply (\x -> (True, ExprVar x, x)) paVarop, - pgApply (\x -> (True, ExprCon x, x)) paConop, - pgApply (\x -> (True, ExprVar x, x)) paMinus - ] - -paDataDecl - = pgThen2 - (\dataa useful -> useful) - (pgItem Ldata) - paDataDecl_main - -paDataDecl_main - = pgThen4 - (\name params eq drhs -> MkDataDecl name (params, drhs)) - paCon - (pgZeroOrMore paVar) - (pgItem Lequals) - (pgOneOrMoreWithSep paConstrs (pgItem Lbar)) - -paConstrs - = pgThen2 - (\con texprs -> (con, texprs)) - paCon - (pgZeroOrMore paAType) - -paType - = pgAlts - [ - pgThen3 - (\atype arrow typee -> TypeArr atype typee) - paAType - (pgItem Larrow) - paType, - pgThen2 - TypeCon - paCon - (pgOneOrMore paAType), - paAType - ] - -paAType - = pgAlts - [ - pgApply TypeVar paVar, - pgApply (\tycon -> TypeCon tycon []) paCon, - pgThen3 - (\l t r -> t) - (pgItem Llparen) - paType - (pgItem Lrparen), - pgThen3 - (\l t r -> TypeList t) - (pgItem Llbrack) - paType - (pgItem Lrbrack), - pgThen3 - (\l t r -> TypeTuple t) - (pgItem Llparen) - (pgTwoOrMoreWithSep paType (pgItem Lcomma)) - (pgItem Lrparen) - ] - -paInfixDecl env toks - = let dump (ExprVar v) = v - dump (ExprCon c) = c - in - pa_UpdateFixityEnv - (pgThen3 - (\assoc prio name -> MkFixDecl name (assoc, prio)) - paInfixWord - (pgApply leStringToInt (pgItem Lintlit)) - (pgApply (\(_, op, _) -> dump op) paOp) - env - toks - ) - -paInfixWord - = pgAlts - [ - pgApply (const InfixL) (pgItem Linfixl), - pgApply (const InfixR) (pgItem Linfixr), - pgApply (const InfixN) (pgItem Linfix) - ] - -pa_UpdateFixityEnv (PFail tok) - = PFail tok - -pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio)) - = let - new_env = (name, assoc_prio) : env - in - POk new_env toks (MkFixDecl name assoc_prio) - -paTopDecl - = pgAlts - [ - pgApply MkTopF paInfixDecl, - pgApply MkTopD paDataDecl, - pgApply MkTopV paValdef - ] - -paModule - = pgThen4 - (\modyule name wheree topdecls -> MkModule name topdecls) - (pgItem Lmodule) - paCon - (pgItem Lwhere) - (pgDeclList paTopDecl) - -parser_test toks - = let parser_to_test - = --paPat - --paExpr - --paValdef - --pgZeroOrMore paInfixDecl - --paDataDecl - --paType - paModule - --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma) - - in - parser_to_test hsPrecTable toks - ---==============================================-- ---=== The Operator-Precedence parser (yuck!) ===-- ---==============================================-- - --- ---==========================================================-- --- -hsAExprOrOp - = pgAlts [paAExpr, paOp] - -hsDoExpr :: [PEntry] -> Parser Expr --- [PaEntry] is a stack of operators and atomic expressions --- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic --- expressions or operators - -hsDoExpr stack env toks = - let - (validIn, restIn, parseIn, err) - = case hsAExprOrOp env toks of - POk env1 toks1 item1 - -> (True, toks1, item1, panic "hsDoExpr(1)") - PFail err - -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err) - (opIn, valueIn, nameIn) - = parseIn - (assocIn, priorIn) - = utLookupDef env nameIn (InfixL, 9) - shift - = hsDoExpr (parseIn:stack) env restIn - in - case stack of - s1:s2:s3:ss - | validIn && opS2 && opIn && priorS2 > priorIn - -> reduce - | validIn && opS2 && opIn && priorS2 == priorIn - -> if assocS2 == InfixL && - assocIn == InfixL - then reduce - else - if assocS2 == InfixR && - assocIn == InfixR - then shift - else PFail (head toks) -- Because of ambiguousness - | not validIn && opS2 - -> reduce - where - (opS1, valueS1, nameS1) = s1 - (opS2, valueS2, nameS2) = s2 - (opS3, valueS3, nameS3) = s3 - (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9) - reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3) - valueS1, []) - : ss) env toks - s1:s2:ss - | validIn && (opS1 || opS2) -> shift - | otherwise -> reduce - where - (opS1, valueS1, nameS1) = s1 - (opS2, valueS2, nameS2) = s2 - reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss) - env toks - (s1:[]) - | validIn -> shift - | otherwise -> POk env toks valueS1 - where - (opS1, valueS1, nameS1) = s1 - [] - | validIn -> shift - | otherwise -> PFail err - ---==========================================================-- ---=== end Parser.hs ===-- ---==========================================================-- - -hsPrecTable :: PEnv -hsPrecTable = [ - ("-", (InfixL, 6)), - ("+", (InfixL, 6)), - ("*", (InfixL, 7)), - ("div", (InfixN, 7)), - ("mod", (InfixN, 7)), - - ("<", (InfixN, 4)), - ("<=", (InfixN, 4)), - ("==", (InfixN, 4)), - ("/=", (InfixN, 4)), - (">=", (InfixN, 4)), - (">", (InfixN, 4)), - - ("C:", (InfixR, 5)), - ("++", (InfixR, 5)), - ("\\", (InfixN, 5)), - ("!!", (InfixL, 9)), - (".", (InfixR, 9)), - ("^", (InfixR, 8)), - ("elem", (InfixN, 4)), - ("notElem", (InfixN, 4)), - - ("||", (InfixR, 2)), - ("&&", (InfixR, 3))] - - -main resps - = [ReadChan stdin, --ReadFile "big_big_test.hs", --"test.fp", - AppendChan stdout (showx parser_res)] - --(show tokens)] - where - cs = case resps !! 0 of - Str s -> s - tokens = laMain cs - parser_res = parser_test tokens - -showx (PFail t) - = "\n\nFailed (boo, hiss)!\n\n" - -showx (POk env [] result) - = "\n\nFailed (EOF token not seen ?!?!)\n\n" - -showx (POk env ((l,n,w,t):_) result) - = "\n\nSucceeded, with:\n Size env = " ++ show (length env) ++ - "\n Line number of last token = " ++ show (l :: Int) ++ "\n\n" - -{- partain: -showx (PFail t) - = "\n\nFailed on token: " {-partain ++ show t -} ++ "\n\n" - -showx (POk env toks result) - = "\n\nSucceeded, with:\n Size env = " ++ show (length env) {-partain ++ - "\n Next token = " ++ show (head toks) ++ - "\n\n Result = " ++ show result ++ "\n\n"-} --} - ---==========================================================-- --- -layn :: [[Char]] -> [Char] - -layn x = f 1 x - where - f :: Int -> [[Char]] -> [Char] - f n [] = [] - f n (a:x) = rjustify 4 (show n) ++") "++a++"\n"++f (n+1) x - - - ---==========================================================-- --- -rjustify :: Int -> [Char] -> [Char] -rjustify n s = spaces (n - length s)++s - where - spaces :: Int -> [Char] - spaces m = copy m ' ' - -copy :: Int -> a -> [a] - -copy n x = take (max 0 n) xs where xs = x:xs - diff --git a/real/reptile/Main-ALT.hs b/real/reptile/Main-ALT.hs deleted file mode 100644 index 65c242e..0000000 --- a/real/reptile/Main-ALT.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Main3.hs - --- LML original: Sandra Foubister, 1990 --- Haskell translation: Colin Runciman, May 1991 --- with (map (AppendChan stdout) toMgr) *and* setup - -module Main(main) where - -import Mgrfuns -import Progfuns -import Auxprogfuns -import Layout -import Tilefuns - -main :: [Response] -> [Request] -main ~(Str fromMgr : _) = - (ReadChan stdin: map (AppendChan stdout) toMgr) - where - toMgr = [set, potatotile ([],1,initalist) (lines fromMgr),clearup] - -set :: [Char] -set = setmode 7 ++ - shapewindow [0,0,1150,900] ++ - setup - -clearup :: [Char] -clearup = shapewindow [0,0,500,500] ++ - font 8 ++ - textreset ++ - clear ++ - font 15 - - - diff --git a/spectral/compreals/makefile b/spectral/compreals/makefile deleted file mode 100644 index e69de29..0000000 diff --git a/spectral/hartel/fft/Main2.hs b/spectral/hartel/fft/Main2.hs deleted file mode 100644 index b67898e..0000000 --- a/spectral/hartel/fft/Main2.hs +++ /dev/null @@ -1,412 +0,0 @@ -module Main (main) -- fft -where { ---partain: import Fast2haskell; -#include "../Fast2haskell2.hs" - strict_show_i::Int -> [Char]; - strict_show_i x=miraseq x (show x); - strict_show_d::Double -> [Char]; - strict_show_d x=miraseq x (show x); - - f_my_cmp a_x a_y= - if (((==) :: (Int -> Int -> Bool)) (fromEnum (f_cmp a_x a_y)) (fromEnum 't')) - then "t" - else - ((++) "f(" ((++) (f_showcomplex a_x) ((++) "-" ((++) (f_showcomplex a_y) - ((++) "=" ((++) (f_showcomplex (((-) :: (Complex_type -> Complex_type -> Complex_type)) a_x a_y)) ")\n")))))); - f_benchmark_main a_n= - let { - r_x=f_large a_n (64 :: Int) - } in (++) (f_sumcode (f_concat (f_map2 f_my_cmp (f_iaamain r_x) (f_rllmain r_x)))) "\n"; - f_sumcode::[Char] -> [Char]; - f_sumcode a_xs= - let { - f_sumcode' [] a_sum a_n=(++) (strict_show_i (((+) :: (Int -> Int -> Int)) a_sum a_n)) ((:) '/' (strict_show_i a_n)); - f_sumcode' (a_x:a_xs) a_sum a_n=f_sumcode' a_xs (((+) :: (Int -> Int -> Int)) a_sum (fromEnum a_x)) (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) - } in f_sumcode' a_xs (0 :: Int) (0 :: Int); -type - T_complex_array=Array_type Complex_type; - f_iaafft::Int -> Int -> T_complex_array -> T_complex_array; - f_iaafft a_size 0 a_xs=a_xs; - f_iaafft a_size a_n a_xs= - let { - r_m=f_log2 (((quot) :: (Int -> Int -> Int)) a_size (((*) :: (Int -> Int -> Int)) a_n (2 :: Int))); - r_xs'=array (bounds a_xs) (f_concat [f_mkpair a_j|a_j<-[(0 :: Int)..((-) :: (Int -> Int -> Int)) a_size (1 :: Int)], - ((==) :: (Int -> Int -> Bool)) (land_i a_j (lshift_i (1 :: Int) r_m)) (0 :: Int)]); - f_mkpair a_j= - let { - r_x=(!) a_xs a_j; - r_y=(!) a_xs r_k; - r_z=((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_size (((*) :: (Int -> Int -> Int)) a_n a_j)) r_y; - r_k=((+) :: (Int -> Int -> Int)) a_j (f_pow2 r_m) - } in (:) ((:=) a_j (((+) :: (Complex_type -> Complex_type -> Complex_type)) r_x r_z)) ((:) ((:=) r_k (((-) :: (Complex_type -> Complex_type -> Complex_type)) r_x r_z)) []) - } in f_iaafft a_size (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) r_xs'; - f_rllfft::Int -> Int -> [Complex_type] -> [Complex_type]; - f_rllfft a_size a_n (a_x:[])=(:) a_x []; - f_rllfft a_size a_n a_xs= - let { - r_ls'=f_map2 ((+) :: (Complex_type -> Complex_type -> Complex_type)) r_ls r_rs''; - r_rs'=f_map2 ((-) :: (Complex_type -> Complex_type -> Complex_type)) r_ls r_rs''; - r_rs''=f_map (((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_size a_n)) r_rs; - (r_ls,r_rs)=f_split (((quot) :: (Int -> Int -> Int)) (length a_xs) (2 :: Int)) a_xs - } in (++) (f_rllfft a_size (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) r_ls') (f_rllfft a_size (((+) :: (Int -> Int -> Int)) (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) - (((quot) :: (Int -> Int -> Int)) a_size (4 :: Int))) r_rs'); - f_bfly::Int -> Int -> Complex_type -> Complex_type -> (Complex_type,Complex_type); - f_bfly a_i a_n a_x a_y= - let { - r_z=((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_i a_n) a_y - } in (((+) :: (Complex_type -> Complex_type -> Complex_type)) a_x r_z,((-) :: (Complex_type -> Complex_type -> Complex_type)) a_x r_z); - f_unitroot::Int -> Int -> Complex_type; - f_unitroot a_i a_n= - let { - r_phi=((*) :: (Double -> Double -> Double)) (((/) :: (Double -> Double -> Double)) (fromIntegral (((*) :: (Int -> Int -> Int)) (2 :: Int) a_n)) (fromIntegral a_i)) c_pi - } in colon_plus (((cos) :: (Double -> Double)) r_phi) (((sin) :: (Double -> Double)) r_phi); - f_pow2::Int -> Int; - f_pow2 a_x=lshift_i (1 :: Int) a_x; - f_log2::Int -> Int; - f_log2 a_x=floor (f_round_d (((/) :: (Double -> Double -> Double)) (((log) :: (Double -> Double)) (fromIntegral a_x)) (((log) :: (Double -> Double)) (2.00000 :: Double)))); - f_round_d::Double -> Double; - f_round_d a_x=entier (((+) :: (Double -> Double -> Double)) a_x (0.500000 :: Double)); - f_split::Int -> [t1] -> ([t1],[t1]); - f_split a_n a_xs=(f_take a_n a_xs,f_drop a_n a_xs); - f_join::Int -> [t1] -> [t1] -> [t1]; - f_join a_n [] []=[]; - f_join a_n a_x a_y= - let { - (r_firstx,r_restx)=f_split a_n a_x; - (r_firsty,r_resty)=f_split a_n a_y - } in (++) r_firstx ((++) r_firsty (f_join a_n r_restx r_resty)); - f_reorder::Int -> [t1] -> [t1]; - f_reorder 1 a_y=a_y; - f_reorder a_n a_y= - let { - (r_left,r_right)=f_split (((quot) :: (Int -> Int -> Int)) r_size (2 :: Int)) a_y; - r_m=((quot) :: (Int -> Int -> Int)) r_size a_n; - r_size=length a_y - } in f_reorder (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) (f_join r_m r_left r_right); - f_rev_bits::Int -> Int -> Int; - f_rev_bits a_wid a_x= - let { - f_rev_bits' a_w a_x a_a= - if (((==) :: (Int -> Int -> Bool)) a_w (0 :: Int)) - then a_a - else - (f_rev_bits' (((-) :: (Int -> Int -> Int)) a_w (1 :: Int)) (rshift_i a_x (1 :: Int)) (lor_i (lshift_i a_a (1 :: Int)) (land_i a_x (1 :: Int)))) - } in f_rev_bits' a_wid a_x (0 :: Int); - f_reorderindex::Int -> Array_type Int; - f_reorderindex a_size=tabulate (f_rev_bits (f_log2 a_size)) (descr (0 :: Int) (((-) :: (Int -> Int -> Int)) a_size (1 :: Int))); - f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; - f_aareorder a_index a_ar= - let { - f_aareorder' a_i=(!) a_ar ((!) a_index a_i) - } in tabulate f_aareorder' (bounds a_ar); - f_intplex::Int -> Int -> Complex_type; - f_intplex a_r a_i=colon_plus (fromIntegral a_r) (fromIntegral a_i); - c_input1::[Complex_type]; - c_input1= - let { - r_as=(:) (0 :: Int) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) ((:) (4 :: Int) ((:) (5 :: Int) - ((:) (6 :: Int) ((:) (7 :: Int) r_as))))))); - r_bs=(:) (0 :: Int) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (1 :: Int) ((:) (0 :: Int) r_bs)))) - } in f_take (16 :: Int) (f_map2 f_intplex r_as r_bs); - c_input2=(:) (f_intplex (2 :: Int) (3 :: Int)) ((:) (f_intplex (6 :: Int) (7 :: Int)) ((:) (f_intplex (4 :: Int) (5 :: Int)) - ((:) (f_intplex (8 :: Int) (9 :: Int)) []))); - c_input3=f_map2 f_intplex ((:) (1 :: Int) ((:) (1 :: Int) ((:) (1 :: Int) ((:) (1 :: Int) ((:) (1 :: Int) - ((:) (1 :: Int) ((:) (1 :: Int) ((:) (1 :: Int) ((:) (1 :: Int) ((:) (((negate) :: (Int -> Int)) (1 :: Int)) ((:) - (((negate) :: (Int -> Int)) (1 :: Int)) ((:) (((negate) :: (Int -> Int)) (1 :: Int)) ((:) (((negate) :: (Int -> Int)) (1 :: Int)) ((:) (((negate) :: (Int -> Int)) (1 :: Int)) - ((:) (((negate) :: (Int -> Int)) (1 :: Int)) ((:) (((negate) :: (Int -> Int)) (1 :: Int)) [])))))))))))))))) [(0 :: Int),(0 :: Int)..]; - c_input4=f_large (5 :: Int) (64 :: Int); - f_extend::Int -> [t1] -> [t1]; - f_extend 0 a_a=a_a; - f_extend a_n a_a=f_extend (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) ((++) a_a a_a); - f_large::Int -> Int -> [Complex_type]; - f_large a_coarse a_fine=f_extend a_coarse [f_intplex (((-) :: (Int -> Int -> Int)) a_fine a_i) (0 :: Int)|a_i<-[(1 :: Int)..a_fine]]; - f_cmp::Complex_type -> Complex_type -> Char; - f_cmp a_ab a_cd= - let { - r_a=realPart a_ab; - r_b=imagPart a_ab; - r_c=realPart a_cd; - r_d=imagPart a_cd - } in - if ( - if (((<=) :: (Double -> Double -> Bool)) (f_abs (((-) :: (Double -> Double -> Double)) r_a r_c)) c_eps) - then (((<=) :: (Double -> Double -> Bool)) (f_abs (((-) :: (Double -> Double -> Double)) r_b r_d)) c_eps) - else - False) - then 't' - else - 'f'; - f_showcomplexarray::T_complex_array -> [Char]; - f_showcomplexarray a_ar= - let { - r_lu=bounds a_ar; - r_l=lowbound r_lu; - r_u=upbound r_lu - } in (++) "[" ((++) (f_showcomplex ((!) a_ar r_l)) ((++) (f_concat [ - (++) ", " (f_showcomplex ((!) a_ar a_i))|a_i<-[((+) :: (Int -> Int -> Int)) r_l (1 :: Int)..r_u]]) "] ")); - f_showcomplexlist::[Complex_type] -> [Char]; - f_showcomplexlist (a_a:a_as)=(++) "[" ((++) (f_showcomplex a_a) ((++) (f_concat [(++) ", " - (f_showcomplex a_a')|a_a'<-a_as]) "] ")); - f_showcomplex::Complex_type -> [Char]; - f_showcomplex a_ri=(++) "C " ((++) (f_showreal (realPart a_ri)) ((++) " " (f_showreal - (imagPart a_ri)))); - f_showreal::Double -> [Char]; - f_showreal a_r= - if (((<=) :: (Double -> Double -> Bool)) (f_abs a_r) c_eps) - then "0" - else - (strict_show_d a_r); - c_eps=(0.500000 :: Double); - f_iaamain::[Complex_type] -> [Complex_type]; - f_iaamain a_xs= - let { - r_index=f_reorderindex r_size; - r_size=length a_xs - } in elems (f_iaafft r_size (((quot) :: (Int -> Int -> Int)) r_size (2 :: Int)) (f_aareorder r_index (listArray (descr (0 :: Int) - (((-) :: (Int -> Int -> Int)) r_size (1 :: Int))) a_xs))); - f_iaashow::[Complex_type] -> [Char]; - f_iaashow a_xs=f_showcomplexlist (f_iaamain a_xs); - f_rllmain::[Complex_type] -> [Complex_type]; - f_rllmain a_xs= - let { - r_size=length a_xs - } in f_reorder r_size (f_rllfft r_size (0 :: Int) a_xs); - f_rllshow::[Complex_type] -> [Char]; - f_rllshow a_xs=f_showcomplexlist (f_rllmain a_xs); - f_abs::Double -> Double; - f_abs a_x= - if (((<=) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double)) - then (((negate) :: (Double -> Double)) a_x) - else - a_x; - f_and::[Bool] -> Bool; - f_and a_xs=f_foldr (&&) True a_xs; - f_cjustify::Int -> [Char] -> [Char]; - f_cjustify a_n a_s= - let { - r_margin=((-) :: (Int -> Int -> Int)) a_n (length a_s); - r_lmargin=((quot) :: (Int -> Int -> Int)) r_margin (2 :: Int); - r_rmargin=((-) :: (Int -> Int -> Int)) r_margin r_lmargin - } in (++) (f_spaces r_lmargin) ((++) a_s (f_spaces r_rmargin)); - f_concat::[[t1]] -> [t1]; - f_concat a_xs=f_foldr (++) [] a_xs; - f_const::t1 -> t2 -> t1; - f_const a_x a_y=a_x; - f_digit::Char -> Bool; - f_digit a_x= - if (((<=) :: (Int -> Int -> Bool)) (fromEnum '0') (fromEnum a_x)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_x) (fromEnum '9')) - else - False; - f_drop::Int -> [t1] -> [t1]; - f_drop 0 a_x=a_x; - f_drop a_n (a_a:a_x)=f_drop (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x; - f_drop a_n a_x=[]; - f_dropwhile::(t1 -> Bool) -> [t1] -> [t1]; - f_dropwhile a_f []=[]; - f_dropwhile a_f (a_a:a_x)= - if (a_f a_a) - then (f_dropwhile a_f a_x) - else - ((:) a_a a_x); - c_e::Double; - c_e=((exp) :: (Double -> Double)) (1.00000 :: Double); - f_filter::(t1 -> Bool) -> [t1] -> [t1]; - f_filter a_f a_x=[a_a|a_a<-a_x,a_f a_a]; - f_foldl::(t1 -> t2 -> t1) -> t1 -> [t2] -> t1; - f_foldl a_op a_r []=a_r; - f_foldl a_op a_r (a_a:a_x)= - let { - f_strict a_f a_x=miraseq a_x (a_f a_x) - } in f_foldl a_op (f_strict a_op a_r a_a) a_x; - f_foldl1::(t1 -> t1 -> t1) -> [t1] -> t1; - f_foldl1 a_op (a_a:a_x)=f_foldl a_op a_a a_x; - f_foldr::(t1 -> t2 -> t2) -> t2 -> [t1] -> t2; - f_foldr a_op a_r []=a_r; - f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x); - f_foldr1::(t1 -> t1 -> t1) -> [t1] -> t1; - f_foldr1 a_op (a_a:[])=a_a; - f_foldr1 a_op (a_a:a_b:a_x)=a_op a_a (f_foldr1 a_op ((:) a_b a_x)); - f_fst::(t1,t2) -> t1; - f_fst (a_a,a_b)=a_a; - f_id::t1 -> t1; - f_id a_x=a_x; - f_index::[t1] -> [Int]; - f_index a_x= - let { - f_f a_n []=[]; - f_f a_n (a_a:a_x)=(:) a_n (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x) - } in f_f (0 :: Int) a_x; - f_init::[t1] -> [t1]; - f_init (a_a:a_x)= - if (null a_x) - then [] - else - ((:) a_a (f_init a_x)); - f_iterate::(t1 -> t1) -> t1 -> [t1]; - f_iterate a_f a_x=(:) a_x (f_iterate a_f (a_f a_x)); - f_last::[t1] -> t1; - f_last a_x=(!!) a_x (((-) :: (Int -> Int -> Int)) (length a_x) (1 :: Int)); - f_lay::[[Char]] -> [Char]; - f_lay []=[]; - f_lay (a_a:a_x)=(++) a_a ((++) "\n" (f_lay a_x)); - f_layn::[[Char]] -> [Char]; - f_layn a_x= - let { - f_f a_n []=[]; - f_f a_n (a_a:a_x)=(++) (f_rjustify (4 :: Int) (strict_show_i a_n)) ((++) ") " ((++) a_a ((++) "\n" - (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x)))) - } in f_f (1 :: Int) a_x; - f_letter::Char -> Bool; - f_letter a_c= - if ( - if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'a') (fromEnum a_c)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'z')) - else - False) - then True - else - if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'A') (fromEnum a_c)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'Z')) - else - False; - f_limit::[Double] -> Double; - f_limit (a_a:a_b:a_x)= - if (((==) :: (Double -> Double -> Bool)) a_a a_b) - then a_a - else - (f_limit ((:) a_b a_x)); - f_lines::[Char] -> [[Char]]; - f_lines []=[]; - f_lines (a_a:a_x)= - let { - r_xs= - if (pair a_x) - then (f_lines a_x) - else - ((:) [] []) - } in - if (((==) :: (Int -> Int -> Bool)) (fromEnum a_a) (fromEnum '\o012')) - then ((:) [] (f_lines a_x)) - else - ((:) ((:) a_a (head r_xs)) (tail r_xs)); - f_ljustify::Int -> [Char] -> [Char]; - f_ljustify a_n a_s=(++) a_s (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))); - f_map::(t1 -> t2) -> [t1] -> [t2]; - f_map a_f a_x=[a_f a_a|a_a<-a_x]; - f_map2::(t1 -> t2 -> t3) -> [t1] -> [t2] -> [t3]; - f_map2 a_f a_x a_y=[a_f a_a a_b|(a_a,a_b)<-f_zip2 a_x a_y]; - f_max::[Int] -> Int; - f_max a_xs=f_foldl1 f_max2 a_xs; - f_max2::Int -> Int -> Int; - f_max2 a_a a_b= - if (((>=) :: (Int -> Int -> Bool)) a_a a_b) - then a_a - else - a_b; - f_member::[Int] -> Int -> Bool; - f_member a_x a_a=f_or (f_map (flip ((==) :: (Int -> Int -> Bool)) a_a) a_x); - f_merge::[Int] -> [Int] -> [Int]; - f_merge [] a_y=a_y; - f_merge (a_a:a_x) []=(:) a_a a_x; - f_merge (a_a:a_x) (a_b:a_y)= - if (((<=) :: (Int -> Int -> Bool)) a_a a_b) - then ((:) a_a (f_merge a_x ((:) a_b a_y))) - else - ((:) a_b (f_merge ((:) a_a a_x) a_y)); - f_min::[Int] -> Int; - f_min a_xs=f_foldl1 f_min2 a_xs; - f_min2::Int -> Int -> Int; - f_min2 a_a a_b= - if (((>) :: (Int -> Int -> Bool)) a_a a_b) - then a_b - else - a_a; - f_mkset::[Int] -> [Int]; - f_mkset []=[]; - f_mkset (a_a:a_x)=(:) a_a (f_filter (flip ((/=) :: (Int -> Int -> Bool)) a_a) (f_mkset a_x)); - f_or::[Bool] -> Bool; - f_or a_xs=f_foldr (||) False a_xs; - c_pi::Double; - c_pi=((*) :: (Double -> Double -> Double)) (4.00000 :: Double) (((atan) :: (Double -> Double)) (1.00000 :: Double)); - f_postfix::t1 -> [t1] -> [t1]; - f_postfix a_a a_x=(++) a_x ((:) a_a []); - f_product::[Int] -> Int; - f_product a_xs=f_foldl ((*) :: (Int -> Int -> Int)) (1 :: Int) a_xs; - f_rep::Int -> t1 -> [t1]; - f_rep a_n a_x=f_take a_n (f_repeat a_x); - f_repeat::t1 -> [t1]; - f_repeat a_x=(:) a_x (f_repeat a_x); - f_reverse::[t1] -> [t1]; - f_reverse a_xs=f_foldl (flip (:)) [] a_xs; - f_rjustify::Int -> [Char] -> [Char]; - f_rjustify a_n a_s=(++) (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))) a_s; - f_scan::(t1 -> t2 -> t1) -> t1 -> [t2] -> [t1]; - f_scan a_op= - let { - f_g a_r []=(:) a_r []; - f_g a_r (a_a:a_x)=(:) a_r (f_g (a_op a_r a_a) a_x) - } in f_g; - f_snd::(t1,t2) -> t2; - f_snd (a_a,a_b)=a_b; - f_sort::[Int] -> [Int]; - f_sort a_x= - let { - r_n=length a_x; - r_n2=((quot) :: (Int -> Int -> Int)) r_n (2 :: Int) - } in - if (((<=) :: (Int -> Int -> Bool)) r_n (1 :: Int)) - then a_x - else - (f_merge (f_sort (f_take r_n2 a_x)) (f_sort (f_drop r_n2 a_x))); - f_spaces::Int -> [Char]; - f_spaces a_n=f_rep a_n ' '; - f_subtract::Int -> Int -> Int; - f_subtract a_x a_y=((-) :: (Int -> Int -> Int)) a_y a_x; - f_sum::[Int] -> Int; - f_sum a_xs=f_foldl ((+) :: (Int -> Int -> Int)) (0 :: Int) a_xs; -data - T_sys_message=F_Stdout [Char] | F_Stderr [Char] | F_Tofile [Char] [Char] | F_Closefile [Char] | F_Appendfile [Char] | F_System [Char] | F_Exit Int; - f_take::Int -> [t1] -> [t1]; - f_take 0 a_x=[]; - f_take a_n (a_a:a_x)=(:) a_a (f_take (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x); - f_take a_n a_x=[]; - f_takewhile::(t1 -> Bool) -> [t1] -> [t1]; - f_takewhile a_f []=[]; - f_takewhile a_f (a_a:a_x)= - if (a_f a_a) - then ((:) a_a (f_takewhile a_f a_x)) - else - []; - f_transpose::[[t1]] -> [[t1]]; - f_transpose a_x= - let { - r_x'=f_takewhile pair a_x - } in - if (null r_x') - then [] - else - ((:) (f_map head r_x') (f_transpose (f_map tail r_x'))); - f_until::(t1 -> Bool) -> (t1 -> t1) -> t1 -> t1; - f_until a_f a_g a_x= - if (a_f a_x) - then a_x - else - (f_until a_f a_g (a_g a_x)); - f_zip2::[t1] -> [t2] -> [(t1,t2)]; - f_zip2 (a_a:a_x) (a_b:a_y)=(:) (a_a,a_b) (f_zip2 a_x a_y); - f_zip2 a_x a_y=[]; - f_zip3 (a_a:a_x) (a_b:a_y) (a_c:a_z)=(:) (a_a,a_b,a_c) (f_zip3 a_x a_y a_z); - f_zip3 a_x a_y a_z=[]; - f_zip4 (a_a:a_w) (a_b:a_x) (a_c:a_y) (a_d:a_z)=(:) (a_a,a_b,a_c,a_d) (f_zip4 a_w a_x a_y a_z); - f_zip4 a_w a_x a_y a_z=[]; - f_zip5 (a_a:a_v) (a_b:a_w) (a_c:a_x) (a_d:a_y) (a_e:a_z)=(:) (a_a,a_b,a_c,a_d,a_e) (f_zip5 a_v a_w a_x a_y a_z); - f_zip5 a_v a_w a_x a_y a_z=[]; - f_zip6 (a_a:a_u) (a_b:a_v) (a_c:a_w) (a_d:a_x) (a_e:a_y) (a_f:a_z)=(:) (a_a,a_b,a_c,a_d,a_e,a_f) (f_zip6 a_u a_v a_w a_x a_y a_z); - f_zip6 a_u a_v a_w a_x a_y a_z=[]; - f_zip::([t1],[t2]) -> [(t1,t2)]; - f_zip (a_x,a_y)=f_zip2 a_x a_y; - f_main a_x=f_benchmark_main a_x; - c_input=(5 :: Int); - main = putStr (f_main c_input) -} diff --git a/spectral/hartel/wave4main/Main2.hs b/spectral/hartel/wave4main/Main2.hs deleted file mode 100644 index c1524b7..0000000 --- a/spectral/hartel/wave4main/Main2.hs +++ /dev/null @@ -1,597 +0,0 @@ -module Main (main) -- wave4main -where { - -#include "../Fast2haskell2.hs" - - f_benchmark_main a_n=(++) (f_sumcode (f_output_print (f_solution a_n))) "\n"; - f_sumcode::[Char] -> [Char]; - f_sumcode a_xs= - let { - f_sumcode' [] a_sum a_n=(++) (show (((+) :: (Int -> Int -> Int)) a_sum a_n)) ((:) '/' (show a_n)); - f_sumcode' (a_x:a_xs) a_sum a_n=f_sumcode' a_xs (((+) :: (Int -> Int -> Int)) a_sum (fromEnum a_x)) (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) - } in f_sumcode' a_xs (0 :: Int) (0 :: Int); -type - T_matrix t1=Array_type (Array_type t1); - f_descr_print::Descr_type -> [Char]; - f_descr_print a_d= - let { - r_low=lowbound a_d; - r_up=upbound a_d - } in (++) "[" ((++) (show r_low) ((++) ".." ((++) (show r_up) "]"))); - f_array_print::(t1 -> [Char]) -> Char -> (Array_type t1) -> [Char]; - f_array_print a_pr a_sep a_arr=(++) (f_descr_print (bounds a_arr)) (f_concat [(:) a_sep (a_pr a_n)|a_n<- - elems a_arr]); - f_matrix_print::(t1 -> [Char]) -> Char -> (T_matrix t1) -> [Char]; - f_matrix_print a_pr a_sep a_mat=(++) (f_descr_print (bounds a_mat)) (f_concat [(:) a_sep (f_array_print a_pr ',' a_a)|a_a<- - elems a_mat]); - f_tabulate2::(Int -> Int -> t1) -> Descr_type -> Descr_type -> T_matrix t1; - f_tabulate2 a_f a_di a_dj= - let { - f_tabhulp a_f a_dj a_i=tabulate (a_f a_i) a_dj - } in tabulate (f_tabhulp a_f a_dj) a_di; - f_getdescr2::(T_matrix t1) -> (Descr_type,Descr_type); - f_getdescr2 a_arr= - let { - r_dx=bounds a_arr; - r_dy=bounds ((!) a_arr (lowbound r_dx)) - } in (r_dx,r_dy); - f_subscript2::T_double_matrix -> Int -> Int -> Double; -- partain:sig changed - f_subscript2 a_a a_i a_j=(!) ((!) a_a a_i) a_j; - f_transpose2::(T_matrix Double) -> T_matrix Double; -- partain: sig changed - f_transpose2 a_arr= - let { - (r_dx,r_dy)=f_getdescr2 a_arr; - f_subhulp a_arr a_j a_i=f_subscript2 a_arr a_i a_j - } in f_tabulate2 (f_subhulp a_arr) r_dy r_dx; - f_updaterange::(T_matrix Double) -> (T_matrix Double) -> T_matrix Double; --partain: sig changed - f_updaterange a_a a_b= - let { - (r_dax,r_day)=f_getdescr2 a_a - } in f_tabulate2 (f_updatehulp a_a a_b) r_dax r_day; - f_updatehulp::(T_matrix Double) -> (T_matrix Double) -> Int -> Int -> Double; -- partain: sig changed - f_updatehulp a_a a_b a_i a_j= - let { - r_in_bx=f_indexindescr a_i r_dbx; - r_in_by=f_indexindescr a_j r_dby; - (r_dbx,r_dby)=f_getdescr2 a_b - } in - if ( - if r_in_bx - then r_in_by - else - False) - then (f_subscript2 a_b a_i a_j) - else - (f_subscript2 a_a a_i a_j); - f_getleftcol::(T_matrix t1) -> Array_type t1; - f_getleftcol a_arr=f_getfirstel a_arr; - f_getrightcol::(T_matrix t1) -> Array_type t1; - f_getrightcol a_arr=f_getlastel a_arr; - f_getbottomrow::(T_matrix t1) -> Array_type t1; - f_getbottomrow a_arr= - let { - f_getbottomhulp a_arr a_i=f_getfirstel ((!) a_arr a_i) - } in tabulate (f_getbottomhulp a_arr) (bounds a_arr); - f_gettoprow::(T_matrix t1) -> Array_type t1; - f_gettoprow a_arr= - let { - f_gettophulp a_arr a_i=f_getlastel ((!) a_arr a_i) - } in tabulate (f_gettophulp a_arr) (bounds a_arr); - f_prependcol::(T_matrix Double) -> (Array_type Double) -> T_matrix Double; -- partain: sig change - f_prependcol a_arr a_col=f_prependel a_arr a_col; - f_appendcol::(T_matrix Double) -> (Array_type Double) -> T_matrix Double; -- partain: sig changed - f_appendcol a_arr a_col=f_appendel a_arr a_col; - f_prependrow::(T_matrix t1) -> (Array_type t1) -> T_matrix t1; - f_prependrow a_arr a_row= - let { - f_prependhulp a_arr a_row a_i=f_prependel ((!) a_arr a_i) ((!) a_row a_i) - } in tabulate (f_prependhulp a_arr a_row) (bounds a_arr); - f_appendrow::(T_matrix t1) -> (Array_type t1) -> T_matrix t1; - f_appendrow a_arr a_row= - let { - f_appendhulp a_arr a_row a_i=f_appendel ((!) a_arr a_i) ((!) a_row a_i) - } in tabulate (f_appendhulp a_arr a_row) (bounds a_arr); - f_indexindescr::Int -> Descr_type -> Bool; - f_indexindescr a_i a_d= - if (((>=) :: (Int -> Int -> Bool)) a_i (lowbound a_d)) - then (((<=) :: (Int -> Int -> Bool)) a_i (upbound a_d)) - else - False; - f_getfirstel::(Array_type t1) -> t1; - f_getfirstel a_arr=(!) a_arr (lowbound (bounds a_arr)); - f_getlastel::(Array_type t1) -> t1; - f_getlastel a_arr=(!) a_arr (upbound (bounds a_arr)); - f_prependel::(Array_type t1) -> t1 -> Array_type t1; - f_prependel a_ar a_x= - let { - r_lu=bounds a_ar; - r_l=lowbound r_lu; - r_u=upbound r_lu; - f_generate a_i= - if (((<) :: (Int -> Int -> Bool)) a_i r_l) - then a_x - else - ((!) a_ar a_i) - } in tabulate f_generate (descr (((-) :: (Int -> Int -> Int)) r_l (1 :: Int)) r_u); - f_appendel::(Array_type t1) -> t1 -> Array_type t1; - f_appendel a_ar a_x= - let { - r_lu=bounds a_ar; - r_l=lowbound r_lu; - r_u=upbound r_lu; - f_generate a_i= - if (((>) :: (Int -> Int -> Bool)) a_i r_u) - then a_x - else - ((!) a_ar a_i) - } in tabulate f_generate (descr r_l (((+) :: (Int -> Int -> Int)) r_u (1 :: Int))); - c_imax,c_jmax,c_imax1,c_jmax1,c_imid,c_imid1,c_jmid,c_jmid1::Int; - c_imax=(7 :: Int); - c_jmax=(7 :: Int); - c_imax1=((+) :: (Int -> Int -> Int)) c_imax (1 :: Int); - c_jmax1=((+) :: (Int -> Int -> Int)) c_jmax (1 :: Int); - c_imid=((-) :: (Int -> Int -> Int)) (((div) :: (Int -> Int -> Int)) c_imax1 (2 :: Int)) (1 :: Int); - c_imid1=((+) :: (Int -> Int -> Int)) c_imid (1 :: Int); - c_jmid=((-) :: (Int -> Int -> Int)) (((div) :: (Int -> Int -> Int)) c_jmax1 (2 :: Int)) (1 :: Int); - c_jmid1=((+) :: (Int -> Int -> Int)) c_jmid (1 :: Int); - c_deltax,c_deltay,c_deltat,c_fcr,c_gam,c_psi,c_gr,c_lbd,c_vwn::Double; - c_deltax=(10000.0 :: Double); - c_deltay=(10000.0 :: Double); - c_deltat=(800.000 :: Double); - c_fcr=(0.000125000 :: Double); - c_gam=(3.20000e-06 :: Double); - c_psi=(0.00000 :: Double); - c_gr=(9.80000 :: Double); - c_lbd=(0.00240000 :: Double); - c_vwn=(0.00000 :: Double); -type - T_mat=T_matrix Double; -type - T_col=Array_type Double; -type - T_row=Array_type Double; -type - T_triplet=(T_mat,T_mat,T_mat); - f_u0::Int -> Int -> Double; - f_u0 a_i a_j=(0.00000 :: Double); - f_v0::Int -> Int -> Double; - f_v0 a_i a_j=(0.00000 :: Double); - f_h0::Int -> Int -> Double; - f_h0 a_i a_j=((/) :: (Double -> Double -> Double)) (fromIntegral (((*) :: (Int -> Int -> Int)) (3 :: Int) a_i)) (fromIntegral c_imax); - f_d::Int -> Int -> Double; - f_d a_i a_j=(30.0000 :: Double); - c_cux,c_cuy,c_ccr,c_cfr,c_windx,c_windy,c_chx,c_chy::Double; - c_cux=((*) :: (Double -> Double -> Double)) c_gr (((/) :: (Double -> Double -> Double)) c_deltat (((*) :: (Double -> Double -> Double)) (2.00000 :: Double) c_deltax)); - c_cuy=((*) :: (Double -> Double -> Double)) c_gr (((/) :: (Double -> Double -> Double)) c_deltat (((*) :: (Double -> Double -> Double)) (2.00000 :: Double) c_deltay)); - c_ccr=((*) :: (Double -> Double -> Double)) c_fcr (((/) :: (Double -> Double -> Double)) c_deltat (4.00000 :: Double)); - c_cfr=((*) :: (Double -> Double -> Double)) (2.00000 :: Double) c_deltat; - c_windx=((*) :: (Double -> Double -> Double)) c_gam (((*) :: (Double -> Double -> Double)) c_vwn (((*) :: (Double -> Double -> Double)) c_vwn (((cos) :: (Double -> Double)) c_psi))); - c_windy=((*) :: (Double -> Double -> Double)) c_gam (((*) :: (Double -> Double -> Double)) c_vwn (((*) :: (Double -> Double -> Double)) c_vwn (((sin) :: (Double -> Double)) c_psi))); - c_chx=((/) :: (Double -> Double -> Double)) c_deltat (((*) :: (Double -> Double -> Double)) (4.00000 :: Double) c_deltax); - c_chy=((/) :: (Double -> Double -> Double)) c_deltat (((*) :: (Double -> Double -> Double)) (4.00000 :: Double) c_deltay); - f_updu::T_mat -> T_mat -> T_mat -> Int -> Int -> Double; - f_updu a_u a_v a_h a_i a_j= - let { - r_height=((*) :: (Double -> Double -> Double)) c_cux (((-) :: (Double -> Double -> Double)) (f_subscript2 a_h a_i a_j) (f_subscript2 a_h (((-) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j)); - r_coriolis= - let { - r_v1=f_subscript2 a_v (((-) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j; - r_v2=f_subscript2 a_v (((-) :: (Int -> Int -> Int)) a_i (1 :: Int)) (((+) :: (Int -> Int -> Int)) a_j (1 :: Int)); - r_v3=f_subscript2 a_v a_i a_j; - r_v4=f_subscript2 a_v a_i (((+) :: (Int -> Int -> Int)) a_j (1 :: Int)) - } in ((*) :: (Double -> Double -> Double)) c_ccr (((+) :: (Double -> Double -> Double)) r_v1 (((+) :: (Double -> Double -> Double)) r_v2 (((+) :: (Double -> Double -> Double)) r_v3 r_v4))); - r_friction=((*) :: (Double -> Double -> Double)) c_cfr (((/) :: (Double -> Double -> Double)) (((-) :: (Double -> Double -> Double)) r_bodem c_windx) (((+) :: (Double -> Double -> Double)) (f_d a_i a_j) (f_d a_i - (((+) :: (Int -> Int -> Int)) a_j (1 :: Int))))); - r_bodem=((*) :: (Double -> Double -> Double)) c_lbd (f_subscript2 a_u a_i a_j) - } in - if (((==) :: (Int -> Int -> Bool)) a_i (0 :: Int)) - then (0.00000 :: Double) - else - if (((==) :: (Int -> Int -> Bool)) a_i c_imax1) - then (0.00000 :: Double) - else - (((+) :: (Double -> Double -> Double)) (((-) :: (Double -> Double -> Double)) (f_subscript2 a_u a_i a_j) r_height) (((-) :: (Double -> Double -> Double)) r_coriolis r_friction)); - f_updv::T_mat -> T_mat -> T_mat -> Int -> Int -> Double; - f_updv a_u a_v a_h a_i a_j= - let { - r_height=((*) :: (Double -> Double -> Double)) c_cuy (((-) :: (Double -> Double -> Double)) (f_subscript2 a_h a_i a_j) (f_subscript2 a_h a_i (((-) :: (Int -> Int -> Int)) a_j (1 :: Int)))); - r_coriolis= - let { - r_u1=f_subscript2 a_u a_i (((-) :: (Int -> Int -> Int)) a_j (1 :: Int)); - r_u2=f_subscript2 a_u (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) (((-) :: (Int -> Int -> Int)) a_j (1 :: Int)); - r_u3=f_subscript2 a_u a_i a_j; - r_u4=f_subscript2 a_u (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j - } in ((*) :: (Double -> Double -> Double)) c_ccr (((+) :: (Double -> Double -> Double)) r_u1 (((+) :: (Double -> Double -> Double)) r_u2 (((+) :: (Double -> Double -> Double)) r_u3 r_u4))); - r_friction=((*) :: (Double -> Double -> Double)) c_cfr (((/) :: (Double -> Double -> Double)) (((-) :: (Double -> Double -> Double)) r_bodem c_windy) (((+) :: (Double -> Double -> Double)) (f_d a_i a_j) (f_d - (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j))); - r_bodem=((*) :: (Double -> Double -> Double)) c_lbd (f_subscript2 a_v a_i a_j) - } in - if (((==) :: (Int -> Int -> Bool)) a_j (0 :: Int)) - then (0.00000 :: Double) - else - if (((==) :: (Int -> Int -> Bool)) a_j c_jmax1) - then (0.00000 :: Double) - else - (((-) :: (Double -> Double -> Double)) (((-) :: (Double -> Double -> Double)) (f_subscript2 a_v a_i a_j) r_height) (((+) :: (Double -> Double -> Double)) r_coriolis r_friction)); - f_updh::T_mat -> T_mat -> T_mat -> Int -> Int -> Double; - f_updh a_u a_v a_h a_i a_j= - let { - r_d1=((*) :: (Double -> Double -> Double)) (((+) :: (Double -> Double -> Double)) (f_d (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j) (f_d (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) - (((+) :: (Int -> Int -> Int)) a_j (1 :: Int)))) (f_subscript2 a_u (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j); - r_d2=((*) :: (Double -> Double -> Double)) (((+) :: (Double -> Double -> Double)) (f_d a_i a_j) (f_d a_i (((+) :: (Int -> Int -> Int)) a_j (1 :: Int)))) (f_subscript2 a_u a_i a_j); - r_d3=((*) :: (Double -> Double -> Double)) (((+) :: (Double -> Double -> Double)) (f_d a_i (((+) :: (Int -> Int -> Int)) a_j (1 :: Int))) (f_d (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) - (((+) :: (Int -> Int -> Int)) a_j (1 :: Int)))) (f_subscript2 a_v a_i (((+) :: (Int -> Int -> Int)) a_j (1 :: Int))); - r_d4=((*) :: (Double -> Double -> Double)) (((+) :: (Double -> Double -> Double)) (f_d a_i a_j) (f_d (((+) :: (Int -> Int -> Int)) a_i (1 :: Int)) a_j)) (f_subscript2 a_v a_i a_j) - } in ((-) :: (Double -> Double -> Double)) (((-) :: (Double -> Double -> Double)) (f_subscript2 a_h a_i a_j) (((*) :: (Double -> Double -> Double)) c_chx (((-) :: (Double -> Double -> Double)) r_d1 r_d2))) (((*) :: (Double -> Double -> Double)) c_chy - (((-) :: (Double -> Double -> Double)) r_d3 r_d4)); - f_printall::[T_triplet] -> [Char]; - f_printall a_trips= - let { - (r_us,r_vs,r_hs)=f_unzip3 a_trips - } in f_printtrip (f_join r_us,f_join r_vs,f_join r_hs); - f_printtrip::T_triplet -> [Char]; - f_printtrip (a_u,a_v,a_h)= - let { - r_us=f_matrix_print (f_showfix (3 :: Int)) '\o012' (f_transpose2 a_u); - r_vs=f_matrix_print (f_showfix (3 :: Int)) '\o012' (f_transpose2 a_v); - r_hs=f_matrix_print (f_showfix (3 :: Int)) '\o012' (f_transpose2 a_h) - } in f_concat ((:) r_us ((:) ((:) '\o012' []) ((:) r_vs ((:) - ((:) '\o012' []) ((:) r_hs ((:) ((:) '\o012' []) [])))))); - f_showfix::Int -> Double -> [Char]; - f_showfix a_w a_x= - let { - r_sign= - if (((<) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double)) - then '-' - else - ' '; - r_i=floor (entier (((+) :: (Double -> Double -> Double)) (0.500000 :: Double) (f_abs (((*) :: (Double -> Double -> Double)) a_x (100.000 :: Double))))); - r_d3_c=toEnum (((+) :: (Int -> Int -> Int)) (fromEnum '0') (((rem) :: (Int -> Int -> Int)) r_i (10 :: Int))); - r_d2_c=toEnum (((+) :: (Int -> Int -> Int)) (fromEnum '0') (((rem) :: (Int -> Int -> Int)) (((div) :: (Int -> Int -> Int)) r_i (10 :: Int)) (10 :: Int))); - r_d1_c=toEnum (((+) :: (Int -> Int -> Int)) (fromEnum '0') (((rem) :: (Int -> Int -> Int)) (((div) :: (Int -> Int -> Int)) r_i (100 :: Int)) (10 :: Int))) - } in - if (((>) :: (Int -> Int -> Bool)) r_i (999 :: Int)) - then "*****" - else - ((:) r_sign ((:) r_d1_c ((:) '.' ((:) r_d2_c ((:) r_d3_c []))))); - f_join::[T_mat] -> T_mat; - f_join a_ranges= - let { - r_arr=f_tabulate2 f_zero2 (descr (0 :: Int) c_imax) (descr (0 :: Int) c_jmax) - } in f_foldl f_updaterange r_arr a_ranges; - f_zero2::Int -> Int -> Double; - f_zero2 a_i a_j=(0.00000 :: Double); - f_unzip3::[(t1,t2,t3)] -> ([t1],[t2],[t3]); - f_unzip3 []=([],[],[]); - f_unzip3 ((a_u,a_v,a_h):a_ts)= - let { - (r_us,r_vs,r_hs)=f_unzip3 a_ts - } in ((:) a_u r_us,(:) a_v r_vs,(:) a_h r_hs); -type - T_double_matrix=T_matrix Double; -type - T_double_array=Array_type Double; -type - T_double_matrix_triple=(T_double_matrix,T_double_matrix,T_double_matrix); -type - T_double_array_tuple=(T_double_array,T_double_array); -type - T_double_matrix_triple_pair=(T_double_matrix_triple,T_double_matrix_triple); - f_matrix_first_col a_m=f_getleftcol a_m; - f_matrix_last_col a_m=f_getrightcol a_m; - -- partain: sig - f_matrix_tab ::(Int -> Int -> Double) -> (Descr_type, Descr_type) -> T_double_matrix; - f_matrix_tab a_f (a_dx,a_dy)=f_tabulate2 a_f a_dx a_dy; - f_matrix_append_col a_m a_c=f_appendcol a_m a_c; - f_matrix_prepend_col a_m a_c=f_prependcol a_m a_c; - f_matrix_sub a_m a_i a_j=f_subscript2 a_m a_i a_j; - f_solution::Int -> T_double_matrix_triple_pair; - f_solution a_n=f_prog c_mf0 c_mg0 (f_first_borders c_mg0) a_n; - f_prog::T_double_matrix_triple -> T_double_matrix_triple -> T_double_array_tuple -> Int -> T_double_matrix_triple_pair; - f_prog a_mfh a_mgh a_mghds 0=(a_mfh,a_mgh); - f_prog a_mfh a_mgh a_mghds a_n= - let { - r_mfh'=f_fvh r_mfu; - r_mghds'=f_first_borders r_mgh'; - r_mgh'=f_gvh r_mgu r_mfulst; - r_mfulst=f_last_borders r_mfu; - r_mfu=f_fu a_mfh a_mghds; - r_mgu=f_gu a_mgh - } in f_prog r_mfh' r_mgh' r_mghds' (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)); - c_mf0,c_mg0::T_double_matrix_triple; - c_mf0=(c_ul0,c_vl0,c_hl0); - c_mg0=(c_ur0,c_vr0,c_hr0); - f_fvh::T_double_matrix_triple -> T_double_matrix_triple; - f_fvh a_mfu=f_fh (f_fv a_mfu); - f_gvh::T_double_matrix_triple -> T_double_array -> T_double_matrix_triple; - f_gvh a_mgu a_mfulst=f_gh (f_gv a_mgu a_mfulst) a_mfulst; - f_first_borders::T_double_matrix_triple -> T_double_array_tuple; - f_first_borders (a_u,a_v,a_h)=(f_matrix_first_col a_v,f_matrix_first_col a_h); - f_last_borders::T_double_matrix_triple -> T_double_array; - f_last_borders (a_u,a_v,a_h)=f_matrix_last_col a_u; - f_fu::T_double_matrix_triple -> T_double_array_tuple -> T_double_matrix_triple; - f_fu (a_u,a_v,a_h) (a_vc,a_hc)= - let { - r_u1=f_matrix_tab (f_updu a_u (f_matrix_append_col a_v a_vc) (f_matrix_append_col a_h a_hc)) c_dul - } in (r_u1,a_v,a_h); - f_fv::T_double_matrix_triple -> T_double_matrix_triple; - f_fv (a_u,a_v,a_h)= - let { - r_v1=f_matrix_tab (f_updv a_u a_v a_h) c_dvl - } in (a_u,r_v1,a_h); - f_fh::T_double_matrix_triple -> T_double_matrix_triple; - f_fh (a_u,a_v,a_h)= - let { - r_h1=f_matrix_tab (f_updh a_u a_v a_h) c_dhl - } in (a_u,a_v,r_h1); - f_gu::T_double_matrix_triple -> T_double_matrix_triple; - f_gu (a_u,a_v,a_h)= - let { - r_u1=f_matrix_tab (f_updu a_u a_v a_h) c_dur - } in (r_u1,a_v,a_h); - f_gv::T_double_matrix_triple -> T_double_array -> T_double_matrix_triple; - f_gv (a_u,a_v,a_h) a_uc= - let { - r_v1=f_matrix_tab (f_updv (f_matrix_prepend_col a_u a_uc) a_v a_h) c_dvr - } in (a_u,r_v1,a_h); - f_gh::T_double_matrix_triple -> T_double_array -> T_double_matrix_triple; - f_gh (a_u,a_v,a_h) a_uc= - let { - r_h1=f_matrix_tab (f_updh (f_matrix_prepend_col a_u a_uc) a_v a_h) c_dhr - } in (a_u,a_v,r_h1); - c_k::Int; - c_k=((div) :: (Int -> Int -> Int)) c_imax1 (2 :: Int); - c_dul,c_dvl,c_dhl,c_dur,c_dvr,c_dhr::(Descr_type,Descr_type); - c_dul=(descr (0 :: Int) c_k,descr (0 :: Int) c_jmax); - c_dvl=(descr (0 :: Int) (((-) :: (Int -> Int -> Int)) c_k (1 :: Int)),descr (0 :: Int) c_jmax1); - c_dhl=(descr (0 :: Int) (((-) :: (Int -> Int -> Int)) c_k (1 :: Int)),descr (0 :: Int) c_jmax); - c_dur=(descr (((+) :: (Int -> Int -> Int)) c_k (1 :: Int)) c_imax1,descr (0 :: Int) c_jmax); - c_dvr=(descr c_k c_imax,descr (0 :: Int) c_jmax1); - c_dhr=(descr c_k c_imax,descr (0 :: Int) c_jmax); - c_ul0,c_vl0,c_hl0,c_ur0,c_vr0,c_hr0::T_double_matrix; - c_ul0=f_matrix_tab f_u0 c_dul; - c_vl0=f_matrix_tab f_v0 c_dvl; - c_hl0=f_matrix_tab f_h0 c_dhl; - c_ur0=f_matrix_tab f_u0 c_dur; - c_vr0=f_matrix_tab f_v0 c_dvr; - c_hr0=f_matrix_tab f_h0 c_dhr; - f_output_print::T_double_matrix_triple_pair -> [Char]; - f_output_print ((a_lu,a_lv,a_lh),(a_ru,a_rv,a_rh))=f_concat [(++) (f_matrix_print (f_showfix (2 :: Int)) '\o012' a_m) "\n"|a_m<-(:) a_lu ((:) a_ru - ((:) a_lv ((:) a_rv ((:) a_lh ((:) a_rh [])))))]; - f_abs::Double -> Double; - f_abs a_x= - if (((<=) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double)) - then (((negate) :: (Double -> Double)) a_x) - else - a_x; - f_and::[Bool] -> Bool; - f_and a_xs=f_foldr (&&) True a_xs; - f_cjustify::Int -> [Char] -> [Char]; - f_cjustify a_n a_s= - let { - r_margin=((-) :: (Int -> Int -> Int)) a_n (length a_s); - r_lmargin=((div) :: (Int -> Int -> Int)) r_margin (2 :: Int); - r_rmargin=((-) :: (Int -> Int -> Int)) r_margin r_lmargin - } in (++) (f_spaces r_lmargin) ((++) a_s (f_spaces r_rmargin)); - f_concat::[[t1]] -> [t1]; - f_concat a_xs=f_foldr (++) [] a_xs; - f_const::t1 -> t2 -> t1; - f_const a_x a_y=a_x; - f_digit::Char -> Bool; - f_digit a_x= - if (((<=) :: (Int -> Int -> Bool)) (fromEnum '0') (fromEnum a_x)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_x) (fromEnum '9')) - else - False; - f_drop::Int -> [t1] -> [t1]; - f_drop 0 a_x=a_x; - f_drop a_n (a_a:a_x)=f_drop (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x; - f_drop a_n a_x=[]; - f_dropwhile::(t1 -> Bool) -> [t1] -> [t1]; - f_dropwhile a_f []=[]; - f_dropwhile a_f (a_a:a_x)= - if (a_f a_a) - then (f_dropwhile a_f a_x) - else - ((:) a_a a_x); - c_e::Double; - c_e=((exp) :: (Double -> Double)) (1.00000 :: Double); - f_filter::(t1 -> Bool) -> [t1] -> [t1]; - f_filter a_f a_x=[a_a|a_a<-a_x,a_f a_a]; - f_foldl::(t1 -> t2 -> t1) -> t1 -> [t2] -> t1; - f_foldl a_op a_r []=a_r; - f_foldl a_op a_r (a_a:a_x)= - let { - f_strict a_f a_x=seq a_x (a_f a_x) - } in f_foldl a_op (f_strict a_op a_r a_a) a_x; - f_foldl1::(t1 -> t1 -> t1) -> [t1] -> t1; - f_foldl1 a_op (a_a:a_x)=f_foldl a_op a_a a_x; - f_foldr::(t1 -> t2 -> t2) -> t2 -> [t1] -> t2; - f_foldr a_op a_r []=a_r; - f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x); - f_foldr1::(t1 -> t1 -> t1) -> [t1] -> t1; - f_foldr1 a_op (a_a:[])=a_a; - f_foldr1 a_op (a_a:a_b:a_x)=a_op a_a (f_foldr1 a_op ((:) a_b a_x)); - f_fst::(t1,t2) -> t1; - f_fst (a_a,a_b)=a_a; - f_id::t1 -> t1; - f_id a_x=a_x; - f_index::[t1] -> [Int]; - f_index a_x= - let { - f_f a_n []=[]; - f_f a_n (a_a:a_x)=(:) a_n (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x) - } in f_f (0 :: Int) a_x; - f_init::[t1] -> [t1]; - f_init (a_a:a_x)= - if (null a_x) - then [] - else - ((:) a_a (f_init a_x)); - f_iterate::(t1 -> t1) -> t1 -> [t1]; - f_iterate a_f a_x=(:) a_x (f_iterate a_f (a_f a_x)); - f_last::[t1] -> t1; - f_last a_x=(!!) a_x (((-) :: (Int -> Int -> Int)) (length a_x) (1 :: Int)); - f_lay::[[Char]] -> [Char]; - f_lay []=[]; - f_lay (a_a:a_x)=(++) a_a ((++) "\n" (f_lay a_x)); - f_layn::[[Char]] -> [Char]; - f_layn a_x= - let { - f_f a_n []=[]; - f_f a_n (a_a:a_x)=(++) (f_rjustify (4 :: Int) (show a_n)) ((++) ") " ((++) a_a ((++) "\n" - (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x)))) - } in f_f (1 :: Int) a_x; - f_letter::Char -> Bool; - f_letter a_c= - if ( - if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'a') (fromEnum a_c)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'z')) - else - False) - then True - else - if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'A') (fromEnum a_c)) - then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'Z')) - else - False; - f_limit::[Double] -> Double; - f_limit (a_a:a_b:a_x)= - if (((==) :: (Double -> Double -> Bool)) a_a a_b) - then a_a - else - (f_limit ((:) a_b a_x)); - f_lines::[Char] -> [[Char]]; - f_lines []=[]; - f_lines (a_a:a_x)= - let { - r_xs= - if (pair a_x) - then (f_lines a_x) - else - ((:) [] []) - } in - if (((==) :: (Int -> Int -> Bool)) (fromEnum a_a) (fromEnum '\o012')) - then ((:) [] (f_lines a_x)) - else - ((:) ((:) a_a (head r_xs)) (tail r_xs)); - f_ljustify::Int -> [Char] -> [Char]; - f_ljustify a_n a_s=(++) a_s (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))); - f_map::(t1 -> t2) -> [t1] -> [t2]; - f_map a_f a_x=[a_f a_a|a_a<-a_x]; - f_map2::(t1 -> t2 -> t3) -> [t1] -> [t2] -> [t3]; - f_map2 a_f a_x a_y=[a_f a_a a_b|(a_a,a_b)<-f_zip2 a_x a_y]; - f_max::[Int] -> Int; - f_max a_xs=f_foldl1 f_max2 a_xs; - f_max2::Int -> Int -> Int; - f_max2 a_a a_b= - if (((>=) :: (Int -> Int -> Bool)) a_a a_b) - then a_a - else - a_b; - f_member::[Int] -> Int -> Bool; - f_member a_x a_a=f_or (f_map (flip ((==) :: (Int -> Int -> Bool)) a_a) a_x); - f_merge::[Int] -> [Int] -> [Int]; - f_merge [] a_y=a_y; - f_merge (a_a:a_x) []=(:) a_a a_x; - f_merge (a_a:a_x) (a_b:a_y)= - if (((<=) :: (Int -> Int -> Bool)) a_a a_b) - then ((:) a_a (f_merge a_x ((:) a_b a_y))) - else - ((:) a_b (f_merge ((:) a_a a_x) a_y)); - f_min::[Int] -> Int; - f_min a_xs=f_foldl1 f_min2 a_xs; - f_min2::Int -> Int -> Int; - f_min2 a_a a_b= - if (((>) :: (Int -> Int -> Bool)) a_a a_b) - then a_b - else - a_a; - f_mkset::[Int] -> [Int]; - f_mkset []=[]; - f_mkset (a_a:a_x)=(:) a_a (f_filter (flip ((/=) :: (Int -> Int -> Bool)) a_a) (f_mkset a_x)); - f_or::[Bool] -> Bool; - f_or a_xs=f_foldr (||) False a_xs; - c_pi::Double; - c_pi=((*) :: (Double -> Double -> Double)) (4.00000 :: Double) (((atan) :: (Double -> Double)) (1.00000 :: Double)); - f_postfix::t1 -> [t1] -> [t1]; - f_postfix a_a a_x=(++) a_x ((:) a_a []); - f_product::[Int] -> Int; - f_product a_xs=f_foldl ((*) :: (Int -> Int -> Int)) (1 :: Int) a_xs; - f_rep::Int -> t1 -> [t1]; - f_rep a_n a_x=f_take a_n (f_repeat a_x); - f_repeat::t1 -> [t1]; - f_repeat a_x=(:) a_x (f_repeat a_x); - f_reverse::[t1] -> [t1]; - f_reverse a_xs=f_foldl (flip (:)) [] a_xs; - f_rjustify::Int -> [Char] -> [Char]; - f_rjustify a_n a_s=(++) (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))) a_s; - f_scan::(t1 -> t2 -> t1) -> t1 -> [t2] -> [t1]; - f_scan a_op= - let { - f_g a_r []=(:) a_r []; - f_g a_r (a_a:a_x)=(:) a_r (f_g (a_op a_r a_a) a_x) - } in f_g; - f_snd::(t1,t2) -> t2; - f_snd (a_a,a_b)=a_b; - f_sort::[Int] -> [Int]; - f_sort a_x= - let { - r_n=length a_x; - r_n2=((div) :: (Int -> Int -> Int)) r_n (2 :: Int) - } in - if (((<=) :: (Int -> Int -> Bool)) r_n (1 :: Int)) - then a_x - else - (f_merge (f_sort (f_take r_n2 a_x)) (f_sort (f_drop r_n2 a_x))); - f_spaces::Int -> [Char]; - f_spaces a_n=f_rep a_n ' '; - f_subtract::Int -> Int -> Int; - f_subtract a_x a_y=((-) :: (Int -> Int -> Int)) a_y a_x; - f_sum::[Int] -> Int; - f_sum a_xs=f_foldl ((+) :: (Int -> Int -> Int)) (0 :: Int) a_xs; -data - T_sys_message=F_Stdout [Char] | F_Stderr [Char] | F_Tofile [Char] [Char] | F_Closefile [Char] | F_Appendfile [Char] | F_System [Char] | F_Exit Int; - f_take::Int -> [t1] -> [t1]; - f_take 0 a_x=[]; - f_take a_n (a_a:a_x)=(:) a_a (f_take (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x); - f_take a_n a_x=[]; - f_takewhile::(t1 -> Bool) -> [t1] -> [t1]; - f_takewhile a_f []=[]; - f_takewhile a_f (a_a:a_x)= - if (a_f a_a) - then ((:) a_a (f_takewhile a_f a_x)) - else - []; - f_transpose::[[t1]] -> [[t1]]; - f_transpose a_x= - let { - r_x'=f_takewhile pair a_x - } in - if (null r_x') - then [] - else - ((:) (f_map head r_x') (f_transpose (f_map tail r_x'))); - f_until::(t1 -> Bool) -> (t1 -> t1) -> t1 -> t1; - f_until a_f a_g a_x= - if (a_f a_x) - then a_x - else - (f_until a_f a_g (a_g a_x)); - f_zip2::[t1] -> [t2] -> [(t1,t2)]; - f_zip2 (a_a:a_x) (a_b:a_y)=(:) (a_a,a_b) (f_zip2 a_x a_y); - f_zip2 a_x a_y=[]; - f_zip3 (a_a:a_x) (a_b:a_y) (a_c:a_z)=(:) (a_a,a_b,a_c) (f_zip3 a_x a_y a_z); - f_zip3 a_x a_y a_z=[]; - f_zip4 (a_a:a_w) (a_b:a_x) (a_c:a_y) (a_d:a_z)=(:) (a_a,a_b,a_c,a_d) (f_zip4 a_w a_x a_y a_z); - f_zip4 a_w a_x a_y a_z=[]; - f_zip5 (a_a:a_v) (a_b:a_w) (a_c:a_x) (a_d:a_y) (a_e:a_z)=(:) (a_a,a_b,a_c,a_d,a_e) (f_zip5 a_v a_w a_x a_y a_z); - f_zip5 a_v a_w a_x a_y a_z=[]; - f_zip6 (a_a:a_u) (a_b:a_v) (a_c:a_w) (a_d:a_x) (a_e:a_y) (a_f:a_z)=(:) (a_a,a_b,a_c,a_d,a_e,a_f) (f_zip6 a_u a_v a_w a_x a_y a_z); - f_zip6 a_u a_v a_w a_x a_y a_z=[]; - f_zip::([t1],[t2]) -> [(t1,t2)]; - f_zip (a_x,a_y)=f_zip2 a_x a_y; - f_main a_x=f_benchmark_main a_x; - c_input=(4000 :: Int); - main = putStr (f_main c_input) -} -- GitLab