diff options
Diffstat (limited to 'miralib/ex')
37 files changed, 1609 insertions, 0 deletions
diff --git a/miralib/ex/README b/miralib/ex/README new file mode 100644 index 0000000..3a68794 --- /dev/null +++ b/miralib/ex/README @@ -0,0 +1,54 @@ +This directory contains a (fairly random) collection of simple scripts +written in Miranda. To try one out (eg fibs.m) say + mira fibs +as a UNIX command - or if you are already inside a Miranda session, say + /f fibs +to make (e.g.) fibs.m your current script. To get into this directory, +while in a Miranda session, say + /cd <ex> + +Each script has some explanatory comments in it. To read the current +script from within a Miranda session say + /e +which invokes the editor on the current script. The scripts are listed +in groups, with some more advanced examples towards the end. The ones +marked (*) may be useful as libraries. + +ack.m the ackermann function +divmodtest.m tests properties of div and mod +fibs.m tabulates fibonacci numbers +hanoi.m solves the problem `towers of hanoi' +powers.m prints a table of powers +primes.m infinite list of prime numbers +pyths.m generates pythagorean triangles + +hamming.m prints hamming numbers +queens.m all solutions to the eight queens problem +queens1.m finds one solution to the eight queens problem +quicksort.m Miranda definition of quicksort +selflines.m curiosity - a self describing scroll of lines +stack.m defines stack as an abstract data type +treesort.m Miranda definition of treesort + +parafs.m Enumerates isomers of alkanes in pictorial form +graphics.m Rectangular graphics package used by parafs.m +keith.m Checks that floating point overflow is trapped +barry.m Math calculations that stress the garbage collector +bigscript.m Tests gc during compilation +makebig.m Creates bigscript.m of any chosen size + +edigits.m infinite decimal expansion of the digits of `e' (literate script) +rational.m package for doing rational arithmetic (*) +refoliate.m a tree problem (literate script) +topsort.m topological sort +matrix.m matrix package (*) +set.m defines set as an abstract data type (*) +kate.lit.m a Miranda script that is also a LaTeX source file + +genmat.m parameterised version of matrix package (*) +just.m text formatting program +mrev (executable) Miranda version of the UNIX `rev' command +box.m (executable) program for reboxing Miranda comments +box symbolic link to box.m +polish.m testbed for unify.m +unify.m package for doing 1st order unification (*) diff --git a/miralib/ex/ack.m b/miralib/ex/ack.m new file mode 100644 index 0000000..8a743eb --- /dev/null +++ b/miralib/ex/ack.m @@ -0,0 +1,9 @@ +||defines ackermann's function, beloved of recursion theorists. Example +|| ack 3 3 +||should yield 61, after doing a huge amount of recursion. Can only be +||called for small arguments, because the values get so big. + +ack 0 n = n+1 +ack (m+1) 0 = ack m 1 +ack (m+1) (n+1) = ack m (ack (m+1) n) +ack m n = error "ack applied to -ve or fractional arg" diff --git a/miralib/ex/barry.m b/miralib/ex/barry.m new file mode 100644 index 0000000..f93af80 --- /dev/null +++ b/miralib/ex/barry.m @@ -0,0 +1,31 @@ +||from Barry Brown, Sierra College -- Aug 2009 +||the critical case is test5, below + +|| Given a number, return the next number in the Collatz sequence +collatz :: num -> num +collatz n = n div 2, if (n mod 2 = 0) + = 3*n+1, if (n mod 2 = 1) + +|| Given a number, return the whole Collatz sequence starting with that +|| number. Note that it does not include the '1' on the end, but that's OK +|| since we're only interested in the length. +collatzseq n = takewhile (>1) (iterate collatz n) + +|| Given a number, return a tuple with the starting number and the +|| length of the Collatz sequence. We'll find the maximum tuple using the +|| next function. The number returned will be 1 less than the actual +|| Collatz sequence length, but that's OK for our purposes. One one of them +|| will be the longest. +collatzpair n = (n, #(collatzseq n)) + +|| Given two tuples, return the greater based on the second term. +maxtuple :: (*,**)->(*,**)->(*,**) +maxtuple x y = x, if (snd x > snd y) + = y, otherwise + + +test1 = map collatzpair [1..9] +test2 = foldr maxtuple (1,0) (map collatzpair [1..9]) +test3 = foldr maxtuple (1,0) (map collatzpair [1..999]) +test4 = foldr maxtuple (1,0) (map collatzpair [1..9999]) +test5 = foldl maxtuple (1,0) (map collatzpair [1..999999]) ||segfaults, ok with foldl diff --git a/miralib/ex/box b/miralib/ex/box new file mode 120000 index 0000000..be14d99 --- /dev/null +++ b/miralib/ex/box @@ -0,0 +1 @@ +box.m
\ No newline at end of file diff --git a/miralib/ex/box.m b/miralib/ex/box.m new file mode 100755 index 0000000..87d404c --- /dev/null +++ b/miralib/ex/box.m @@ -0,0 +1,244 @@ +#! /home/dat/mira/states/src/miranda/mira -exec +|| Contributed by John Cupitt, University of Kent + +||A while ago Steve Hill (I think) appealed for useful Miranda programs +||-- well, here is the greatest productivity aid for Miranda hackers +||since ball-point pens. A 'vi' type filter to *rebox your comments*!! +||Amazing. It turns dull, unexciting notes like: + +|| Given a node in the tree, +||examine the branches and chose the exit with the +|| highest score. + +||into: + +||----------------------------------------------------------------------|| +|| Given a node in the tree, examine the branches and chose the exit || +|| with the highest score. || +||----------------------------------------------------------------------|| + +||Any comments welcome -- my Miranda is not as hot as it could be ... + +||John + +||----------------------------------------------------------------------|| +|| Box up Miranda comments. A filter from stdin to stdout +|| do_box :: [char] -> [char] || +|| - Strip ||s, reformat, rebox. || +||----------------------------------------------------------------------|| + +main = [Stdout (do_box $-)] + +||----------------------------------------------------------------------|| +|| Reboxing done in a pipeline of five stages. || +|| - Split the input into lines || +|| - Strip '||'s from input || +|| - Lex the input, breaking into tokens || +|| - Rejig tokens to produce fmted type output || +|| - Output tokens as [char] with a box drawn around them || +|| Formatting rules: || +|| - Lines starting '||-' are deleted || +|| - Leading & trailing '||' removed || +|| - Lines starting with a tab are not reformatted || +|| - Blank lines are 'new paragraph' || +||----------------------------------------------------------------------|| + +||----------------------------------------------------------------------|| +|| First a few types and useful little functions. || +||----------------------------------------------------------------------|| + +|| Useful constants +outWid = 68 || Width of the text in our boxes +boxWid = 72 || Size of the box we draw + +|| A token +tok ::= Word [char] | Newpara | Line [char] + +|| Useful character classifier +whitespace :: char -> bool +whitespace ch + = True, if ch = '\n' \/ ch = '\t' \/ ch = ' ' + = False, otherwise + +|| An edge of a box boxWid across +edge :: [char] +edge = "||" ++ (rep (boxWid-2) '-') ++ "||\n" + +|| Find the length of a line containing tabs +len :: [char] -> num +len str + = len' 0 str + where + len' n [] + = n + len' n (a:rest) + = len' (n+tab_space) rest, if a = '\t' + = len' (n+1) rest, otherwise + where + tab_space + = 8 - (n mod 8) + +|| Useful when doing output --- only attach first param if its not []. +no_blank :: [char] -> [[char]] -> [[char]] +no_blank a b + = a : b, if a ~= [] + = b, otherwise + +||----------------------------------------------------------------------|| +|| The main function. Call from a shell script in your /bin directory || +|| looking something like: || +|| #! /usr/bin/mira -exec || +|| main = [Stdout (do_box $-)] || +|| %include "../mira/box/box.m" || +||----------------------------------------------------------------------|| + +do_box :: [char] -> [char] +do_box input + = edge ++ rejig input ++ edge + where + rejig = re_box . format . lex_start . strip_start . split + +||----------------------------------------------------------------------|| +|| The first stage in processing. Split the input [char] into lines as || +|| [[char]]. || +||----------------------------------------------------------------------|| + +|| Split the text into a list of lines +split :: [char] -> [[char]] +split input + = split' [] input + where + split' sofar (a:input) + = sofar : split input, if a = '\n' + = split' (sofar ++ [a]) input, otherwise + split' sofar [] + = no_blank sofar [] || No extra blank lines! + +||----------------------------------------------------------------------|| +|| The next stage ... strip old '||'s from the input. Remove: || +|| - Lines starting '||-' || +|| - Strip leading '||'s || +|| - Strip trailing '||'s & trailing spaces || +||----------------------------------------------------------------------|| + +|| At the start of a line: +strip_start :: [[char]] -> [[char]] +strip_start ([]:input) + = [] : strip_start input || Keep blank lines +strip_start (('|':'|':line):input) + = strip_start' line + where + strip_start' ('-':rest) + = strip_start input || Strip '||---||' lines + strip_start' rest + = strip_rest rest input || Strip leading '||' +strip_start (line:input) + = strip_rest line input || Pass rest through +strip_start [] + = [] + +|| Scan along the rest of the line looking for trailing '||'s to strip. +strip_rest :: [char] -> [[char]] -> [[char]] +strip_rest line input + = strip_rest' (rev line) input + where + strip_rest' ('|':'|':rest) input + = strip_rest' rest input || Strip trailing || + strip_rest' (x:rest) input + = strip_rest' rest input, if whitespace x + strip_rest' line input + = (rev line) : strip_start input + +|| Efficient(ish) reverse +rev list + = rev' [] list + where + rev' sofar (a:x) + = rev' (a:sofar) x + rev' sofar [] + = sofar + +||----------------------------------------------------------------------|| +|| The next stage ... Break the input into Word, Newpara and Line || +|| tokens. Newpara for blank lines and line starting with space; Line || +|| for lines starting with a tab. || +||----------------------------------------------------------------------|| + +|| At the start of a line. +lex_start :: [[char]] -> [tok] +lex_start ([]:input) + = Newpara : lex_start input || Preserve blank lines +lex_start (('\t':rest):input) + = Line ('\t':rest) : lex_start input || Don't format tab lines +lex_start (line:input) + = lex_rest (strip_ws line) input || Lex to eol +lex_start [] + = [] + +|| In the middle of a line. Try to take words off the front of what we +|| have so far. +lex_rest :: [char] -> [[char]] -> [tok] +lex_rest [] input + = lex_start input +lex_rest sofar input + = Word wd : lex_rest (strip_ws rest) input + where + (wd, rest) + = break_word sofar + +|| Strip ws from the start of the line +strip_ws (a:input) + = (a:input), if ~whitespace a + = strip_ws input, otherwise +strip_ws [] + = [] + +|| Break the word from the front of a line of text. Return the remains +|| of the line along with the word. +break_word :: [char] -> ([char], [char]) +break_word (a:line) + = ([a] ++ rest, tag), if ~whitespace a + = ([], (a:line)), otherwise + where + (rest, tag) + = break_word line +break_word [] + = ([],[]) + +||----------------------------------------------------------------------|| +|| Almost the last stage ... Turn [tok] back into [[char]]. Format || +|| onto outWid character lines. || +||----------------------------------------------------------------------|| + +format :: [tok] -> [[char]] +format input + = format' [] input + where + format' sofar (Word wd:rest) + = format' (sofar ++ " " ++ wd) rest, if #sofar + #wd < outWid + = sofar : format' (" " ++ wd) rest, otherwise + format' sofar (Newpara:rest) + = no_blank sofar ([] : format rest) + format' sofar (Line line:rest) + = no_blank sofar (line : format rest) + format' sofar [] + = no_blank sofar [] + +||----------------------------------------------------------------------|| +|| The final stage. Box up a list of formatted lines. Try to be clever || +|| about using tabs on the ends of lines. || +||----------------------------------------------------------------------|| + +|| Draw a box boxWid across. +re_box :: [[char]] -> [char] +re_box (line:rest) + = "||" ++ line ++ padding ++ "||\n" ++ (re_box rest) + where + padding + = rep n_tab '\t' + n_tab + = (boxWid - line_length + 7) div 8 + line_length + = len ("||" ++ line) +re_box [] + =[] diff --git a/miralib/ex/divmodtest.m b/miralib/ex/divmodtest.m new file mode 100644 index 0000000..28b5e03 --- /dev/null +++ b/miralib/ex/divmodtest.m @@ -0,0 +1,11 @@ +||This script defines tests for three properties of div and mod, each +||checked over a small range of values including various combinations +||of signs. Each test should yield the result True, or there is +||something wrong with the arithmetic on your machine! + +test1 = and [a div b = entier (a/b) | a,b <- [-15..15]; b~=0] +test2 = and [b*(a div b) + a mod b = a | a,b <- [-15..15]; b~=0] +test3 = and [ ok a b | a,b <- [-15..15]; b~=0] + where + ok a b = 0 <= a mod b < b, if b>0 + = b < a mod b <= 0, if b<0 diff --git a/miralib/ex/edigits.m b/miralib/ex/edigits.m new file mode 100644 index 0000000..216757f --- /dev/null +++ b/miralib/ex/edigits.m @@ -0,0 +1,73 @@ +> ||note that this is a literate script + +Programming example - generating the digits of `e' + +We wish to write a program to generate the (decimal) digits of `e', as +an infinite string. Fact - the value of `e', the base of natural +logarithms, is given by the series + +e = 1 + 1/1! + 1/2! + 1/3! + ... + +where by n! we mean the factorial of n, = n*(n-1)...*2*1. Now, we can +choose to represent fractional numbers using a peculiar base system, in +which the weight of the i'th digit after the point is 1/i! (so note that +the `carry factor' by which we must multiply a unit from the i'th digit +when carrying it back to the i-1'th is i). Written to this funny base, +`e' is just + 2.1111111111............ +so the string we require may be obtained by converting fractional part +of the above numeral from the `funny base' to decimal. Thus + +> edigits = "2." ++ convert (repeat 1) + +The function `convert' takes for its argument a fraction in the funny +base (here represented as an infinite list of numbers) and returns its +value in decimal, as an infinite list of digits. The algorithm for +converting a fraction from another base to decimal, is as follows: (i) +multiply all digits by ten, and renormalise, using the appropriate carry +factors (ii) the whole number part of the result gives the first decimal +digit (iii) repeat the process on the fractional part of the result to +generate the remaining digits. Thus + +> convert x = mkdigit (hd x'):convert (tl x') +> where x' = norm 2 (0:map (10*) x) +> mkdigit n = decode(n + code '0'), if n<10 + +It remains to define the function `norm' which does renormalisation. A +naive (and almost correct) definition is + + norm c (d:x) = d + e' div c: e' mod c : x' + where + (e':x') = norm (c+1) x + +However, this is not a well-founded recursion, since it must search +arbitrarily far to the right in the fraction being normalised before +printing the first digit. If you try printing `edigits' with the above +as your definition of norm, you will get "2." followed by a long +silence. + +We need a theorem which will limit the distance from which a carry can +propagate. Fact: during the conversion of this fraction the maximum +possible carry from a digit to its leftward neighbour is 9. (The proof +of this, left as a (not very hard) exercise for the mathematically +minded reader, is by induction on the number of times the conversion +algorithm is applied.) This leads us to the following slightly more +cautious definition of `norm' + +> norm c (d:e:x) = d + e div c: e' mod c : x', if e mod c + 9 < c +> = d + e' div c : e' mod c : x', otherwise +> where +> (e':x') = norm (c+1) (e:x) + +Our solution is now complete. To see the results, enter mira with this +file as the current script and say + edigits +Hit control-C (interrupt) when you have seen enough digits. + +[Note: If nothing happens until you interrupt the evaluation, this may +be because the output from Miranda to your terminal is being +line-buffered, so the characters are not appearing on your screen as +Miranda prints them, but being saved up until there is a whole line to +print. Output from the computer to your terminal should not be line +buffered when Miranda is running - ask someone how to disable the line +buffering, if this is the case.] diff --git a/miralib/ex/fib.m b/miralib/ex/fib.m new file mode 100644 index 0000000..d84d33f --- /dev/null +++ b/miralib/ex/fib.m @@ -0,0 +1,4 @@ +||fib n computes the n'th fibonacci number +||by using /count you can estimate the asymptotic limit of (fib n/time to compute fib n) +fib n = 1, if n<=2 + = fib(n-1) + fib(n-2), otherwise diff --git a/miralib/ex/fibs.m b/miralib/ex/fibs.m new file mode 100644 index 0000000..39c805d --- /dev/null +++ b/miralib/ex/fibs.m @@ -0,0 +1,16 @@ +||This program tabulates the values of `fib i' a function for computing +||fibonacci numbers, in a list `fibs'. Because the function is memoised +||(i.e. it uses table lookup when it recurses) it runs in linear time. +||To see the fibonacci numbers say. +|| test + +fibs = map fib [0..] +fib 0 = 0 +fib 1 = 1 +fib (n+2) = fibs!(n+1) + fibs!n + +test = layn (map shownum fibs) + +||P.S. There is a more direct way of defining fibs, using a list comprehension +|| fibs = [a | (a,b) <- (0,1), (b,a+b) .. ] +||this also runs in linear time diff --git a/miralib/ex/genmat.m b/miralib/ex/genmat.m new file mode 100644 index 0000000..27c2f88 --- /dev/null +++ b/miralib/ex/genmat.m @@ -0,0 +1,84 @@ +||The matrix package again, but this time parameterised over an arbitrary +||element type, with a zero, a unit and four functions of arithmetic. +||Example - to instantiate this package with numbers as the element type, +||in another script, say:- +|| %include <ex/genmat> { elem==num; zero=0; unit=1; +|| plus=+; minus=-; times=*; divide=/; } + +||However another possibility would be to use the package to do matrix +||calculations over rationals (as defined in <ex/rat>) thus:- +|| %include <ex/genmat> +|| { elem==rational; zero=mkrat 0; unit=mkrat 1; +|| plus=rplus; minus=rminus; times=rtimes; divide=rdiv; } + +%export matrix idmat matadd matsub matmult prescalmult postscalmult + mkrow mkcol det adjoint inv + +%free { elem::type; zero,unit::elem; + plus,minus,times,divide::elem->elem->elem; + } + +matrix == [[elem]] + +idmat :: num->matrix ||identity matrix of given size +idmat n = [[delta i j|j<-[1..n]]|i<-[1..n]] + where + delta i j = unit, if i=j + = zero, otherwise + +matadd :: matrix->matrix->matrix +matadd x y = map2 vadd x y + where + vadd x y = map2 plus x y + +matsub :: matrix->matrix->matrix +matsub x y = map2 vsub x y + where + vsub = map2 minus + +matmult :: matrix->matrix->matrix +matmult x y = outer inner x (transpose y) ||* +inner x y = summate (map2 times x y) +outer f x y = [[f a b|b<-y]|a<-x] + +||*note that transpose is already defined in the standard environment + +summate = foldl plus zero + +prescalmult :: elem->matrix->matrix ||premultiply a matrix by a scalar +prescalmult n x = map (map (times n)) x + +postscalmult :: elem->matrix->matrix ||postmultiply a matrix by a scalar +postscalmult n x = map (map ($times n)) x + +||we need both the above because element multiplication may not be +||commutative + +mkrow :: [elem]->matrix ||make vector into matrix with a single row +mkrow x = [x] + +mkcol :: [elem]->matrix ||make vector into matrix with a single column +mkcol x = map (:[]) x + +det :: matrix->elem ||determinant, of square matrix +det [[a]] = a +det xs = summate [(xs!0!i) $times cofactor 0 i xs|i<-index xs], if #xs=#xs!0 + = error "det of nonsquare matrix", otherwise +cofactor i j xs = parity (i+j) $times det (minor i j xs) +minor i j xs = [omit j x | x<-omit i xs] +omit i x = take i x ++ drop (i+1) x + +parity::num->elem +parity i = unit, if i mod 2 = 0 + = zero $minus unit, otherwise + +adjoint :: matrix->matrix ||adjoint, of square matrix +adjoint xs = transpose[[cofactor i j xs | j<-index xs] | i <- index xs] + +inv :: matrix->matrix ||inverse, of non-singular square matrix +inv xs = transpose[[cofactor i j xs $divide h | j<-index xs] | i <- index xs] + where + h = det xs +||The above is a literal transcription of the mathematical definition of +||matrix inverse. A less naive version of the package would rewrite +||this to use Gaussian elimination. diff --git a/miralib/ex/graphics.m b/miralib/ex/graphics.m new file mode 100644 index 0000000..ca2f09a --- /dev/null +++ b/miralib/ex/graphics.m @@ -0,0 +1,164 @@ +||package for developing rectangular pictures composed of ascii characters +||DT Jan 84 +||all pictures are conceived as lying in an infinite plane with origin at (0,0) +||and filled with blanks except where non-blank chars have been specified +query * ::= FAIL | SUCCEED * +||generic union type, often useful -- should probably be in library +picture ::= MKPIC (num,num)! [[char]] | EMPTYPIC +||MKPIC holds a figure with its north west corner at the given coordinates +frame :: picture->(num,num,num,num) +||returns (left,right,low,high) of smallest rectangle containing the figure +frame(MKPIC (x,y) a) = (x,x+#a!0-1,y-#a+1,y) +||it is an error to apply frame to the empty picture +printpic :: picture->[char] ||prints pic with frame north west justified +printpic EMPTYPIC = [] +printpic (MKPIC (x,y) a) = concat[p ++ "\n" | p <- a] +printpic1 :: picture->[char] ||likewise, right shifted 8 +printpic1 EMPTYPIC = [] +printpic1 (MKPIC (x,y) a) = concat[" "++p ++ "\n" | p <- a] +alignpic :: num->num->picture->[char] +||prints picture as seen looking south east from the given cooordinates -- +||only parts of the figure onside from this position appear of course +alignpic x y EMPTYPIC = [] +alignpic x y (MKPIC (x1,y1) a) + = newlines (y-y1) ++ concat a1, if y>y1 + = concat(drop (y1-y) a1), if y<y1 + = concat a1, otherwise + where + a1 = [drop (x-x1) p ++ "\n" | p <- a], if x>x1 + = [spaces (x1-x) ++ p ++ "\n" | p <- a], if x<x1 + = [p ++ "\n" | p <- a], otherwise +translate :: num->num->picture->picture ||move picture x right and y up +translate x y EMPTYPIC = EMPTYPIC +translate x y (MKPIC (x1,y1) a) = MKPIC (x+x1,y+y1) a +rotate :: num->picture->picture +||rotate the picture by n*pi/2 radians anticlockwise about (0,0) +rotate n EMPTYPIC = EMPTYPIC +rotate 0 = id +rotate 1 = reflect 3.reflect 2 ||result from group theory +rotate 2 (MKPIC (x,y) a) = + MKPIC (-(x+#a!0-1),-(y-#a+1)) (reverse (map reverse a)) +rotate 3 = reflect 2.reflect 3 ||group theory +rotate n = rotate (n mod 4) ||other values of n +reflect :: num->picture->picture +||reflect about a line inclined at n*pi/4 to the x axis +reflect n EMPTYPIC = EMPTYPIC +reflect 0 (MKPIC (x,y) a) = MKPIC (x,-(y-#a+1)) (reverse a) +reflect 1 = reflect 3.rotate 2 ||group theory +reflect 2 (MKPIC (x,y) a) = MKPIC (-(x+#a!0-1),y) (map reverse a) +reflect 3 (MKPIC (x,y) a) = MKPIC (-y,-x) (transpose a') + where a' = map(map f)a + f '-' = '|' + f '|' = '-' + f etc = etc +reflect n = reflect (n mod 4) ||other values of n +composepic :: [picture]->query picture +||tries to combine the given list of pictures to yield a composite picture +|| -- fails if any parts of the figures overlap +composepic = foldr apic (SUCCEED EMPTYPIC) +compositions :: [[picture]]->[picture] +||finds all possible ways of composing a picture (with no overlaps) with +||one component from each of the given picture lists +||this will probably be more useful in practice than composepic +compositions [] = [EMPTYPIC] +compositions (xx:etc) = f[apic1 x r // x <- xx; r <- compositions etc] + where + f [] = [] + f (FAIL:x) = f x + f (SUCCEED a:x) = a: f x +overlaypic :: [picture]->picture +||similar to the above but allows pictures earlier in the given list to hide +||details of later ones, so the result is always a picture +overlaypic = foldr opic EMPTYPIC +apic :: picture->query picture->query picture ||picture addition +p $apic SUCCEED EMPTYPIC = SUCCEED p +p $apic FAIL = FAIL +EMPTYPIC $apic q = q +MKPIC (x1,y1) a $apic SUCCEED (MKPIC (x2,y2) b) + = FAIL, if xx=FAIL + = SUCCEED (MKPIC (x,y) (f xx)), otherwise + where + x = min[x1,x2] + y = max[y1,y2] + xx = pointwiseadd a1 b1 + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 + f(SUCCEED c) = c +apic1 :: picture->picture->query picture ||picture addition mark2 +p $apic1 EMPTYPIC = SUCCEED p +EMPTYPIC $apic1 q = SUCCEED q +MKPIC (x1,y1) a $apic1 MKPIC (x2,y2) b + = FAIL, if xx=FAIL + = SUCCEED (MKPIC (x,y) (f xx)), otherwise + where + x = min[x1,x2] + y = max[y1,y2] + xx = pointwiseadd a1 b1 + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 + f(SUCCEED c) = c +opic :: picture->picture->picture ||picture superposition +p $opic EMPTYPIC = p +EMPTYPIC $opic q = q +MKPIC (x1,y1) a $opic MKPIC (x2,y2) b + = MKPIC (x,y) (pointwiseoverlay a1 b1) + where + x = min[x1,x2] + y = max[y1,y2] + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 +sidepad n r a = [spaces n ++ p ++ spaces r | p <- a] +toppad n a = f n + where + f n = a, if n<=0 + = spaces (#a!0):f (n-1), otherwise +pointwiseoverlay :: [[char]]->[[char]]->[[char]] +pointwiseoverlay a b = f a b + where + f [] b = b + f a [] = a + f (p:a) (q:b) = g p q:f a b + g [] q = q + g p [] = p + g (c1:p) (c2:q) = c2:g p q, if c1=' ' + = c1:g p q, otherwise +pointwiseadd :: [[char]]->[[char]]->query [[char]] +pointwiseadd a b = SUCCEED c, if and [~member z clashchar | z<-c] + = FAIL, otherwise + where + c = f a b + f [] b = b + f a [] = a + f (p:a) (q:b) = g p q:f a b + g [] q = q + g p [] = p + g (c1:p) (c2:q) = c2:g p q, if c1=' ' + = c1:g p q, if c2=' ' + = clashchar:g p q, otherwise +clashchar = '\0' ||assumed not to be present in any normal picture +pic :: num->num->[[char]]->picture +||takes a rectangular array of chars and turns it into a picture with its north +||west corner at the given x y position +pic x y a = EMPTYPIC, if and[p=[]|p<-a] + ||covers both a=[] and elements a all [] + = pic x (y-1) (tl a), if and[c=' ' | c<-hd a] + ||strip blank rows + = pic (x+1) y (map tl a), if and[hd p=' ' | p <- a] + ||strip blank cols + = MKPIC (x,y) a, otherwise + ||what about east and south trimming? -- fix later +||we have assumed given a rectangular and not containing control chars, we +||ought perhaps to check this when a picture is formed -- fix later + +newlines n = rep n '\n' +closure :: (*->[*])->[*]->[*]; +||takes the closure of a set under a pointwise function that returns +||increments to the set +closure f s = g s s + where + g r t = [], if t=[] + = t ++ g(r ++ t)(mkset[x|x<-concat(map f t);~member r x]), + otherwise diff --git a/miralib/ex/hamming.m b/miralib/ex/hamming.m new file mode 100644 index 0000000..3ebb6ce --- /dev/null +++ b/miralib/ex/hamming.m @@ -0,0 +1,19 @@ +||this is a problem described by Dijkstra in his book, A Discipline of +||Programming, and attributed by him to Dr Hamming, of Bell Labs. +||Print in ascending order all numbers of the form +|| 2**a.3**b.5**c a,b,c all >=0 +||the solution here is based on a method using communicating processes. +||ham is the list of numbers, to see them, say +|| ham +||hit control-C (interrupt) when you have seen enough! + +ham = 1 : foldr1 merge [mult 2 ham, mult 3 ham, mult 5 ham] + where + mult n x = [n*a|a<-x] + merge (a:x) (b:y) = a : merge x y, if a=b + = a : merge x (b:y), if a<b + = b : merge (a:x) y, if a>b + +||Note that there is a function called `merge' in the standard +||environment, but unlike the one defined above it does not remove +||duplicates from the lists being merged. diff --git a/miralib/ex/hanoi.m b/miralib/ex/hanoi.m new file mode 100644 index 0000000..b927ca3 --- /dev/null +++ b/miralib/ex/hanoi.m @@ -0,0 +1,11 @@ +||This script generates a solution to the well known `Towers of Hanoi' +||problem. To see the moves (for a game with 12 discs) say +|| soln + +soln = title++hanoi 12 "A" "B" "C" +title = "SOLUTION TO TOWERS OF HANOI WITH 8 DISCS\n\n" +hanoi 0 a b c = [] +hanoi (n+1) a b c = hanoi n a c b + ++ move a b ++ + hanoi n c b a +move a b = "move the top disc from "++a++" to "++b++"\n" diff --git a/miralib/ex/just.m b/miralib/ex/just.m new file mode 100644 index 0000000..9dca373 --- /dev/null +++ b/miralib/ex/just.m @@ -0,0 +1,98 @@ +||Text formatting program (DT) +||Reformats text to a specified width, with line-fill + +%export just + +||To try this out from within a Miranda session, say e.g. +|| just 60 (read "file") +||where "file" contains some text you want to reformat. + +||You could also make it into a UNIX filter -- see the example `mrev'. + +||----------------------------------------------------------------------|| +|| in this program we move between three different representations of || +|| text - as a flat list of characters, including spaces and newlines || +|| - as a list of lines (containing spaces but not newlines) || +|| - and as a list of list of words. || +||----------------------------------------------------------------------|| + +text == [char] +line == [char] +word == [char] + +just::num->text->text ||the main function +just n = concat.map(reformat n).paras.map words.lines + +||lines::text->[line] +||lines is defined in <stdenv> - it breaks a string into lines, +||removing the newline characters + +paras::[[word]]->[[word]] +||make each paragraph into one long line, by joining adjacent +||non-blank lines +paras (a:b:x) = paras ((a++b):x), if a~=[]~=b + = a:paras (b:x), otherwise +paras (a:[]) = a:[] +paras [] = [] + +reformat::num->[word]->text +||reformat a paragraph to width n +reformat n [] = "\n" ||the empty paragraph represents a blank line +reformat n x = lay(justify n (partition n x)) + +||lay::[line]->text +||lay is defined in <stdenv> - it is the inverse of lines + +justify::num->[[word]]->[line] +justify n para = map(fill_line n)(init para)++[unwords(last para)] + +partition::num->[word]->[[word]] +||break a paragraph into lines, with as many words as will fit in width +||n on each line (except the last) +partition n [] = [] +partition n x = x1 : partition n rest + where + (x1,rest) = grab [] x + grab y (w:x) = grab (w:y) x, if sum(map(#)y)+#y+#w <= n + = (reverse y,w:x), otherwise + grab y [] = (reverse y,[]) + +fill_line :: num->[word]->line +||make words into a line of length n exactly, by inserting enough spaces +fill_line n words + = (concat.concat) (transpose [words,mkspaces (w-1) (n-sw)]) + where + w = #words + sw = sum(map (#) words) + +mkspaces :: num->num->[[char]] +||return s spaces broken into n groups +mkspaces n s = map f [1..n], if n mod 2=0 ||see note + = map f [n,n-1..1], otherwise + where + f i = rep (s div n + delta) ' ' + where + delta = 1, if i<=s mod n + = 0, otherwise +||note: we put the extra spaces in sometimes from the left and sometimes +||from the right, depending on the parity of n. This is to avoid +||visually unbalancing the text by having all the extra spaces towards +||one margin. Using the parity of n to decide this is arbitrary. + +words :: line->[word] +||break a line into words +words = filter (~=[]) . foldr (breakon ' ') [[]] + +unwords :: [word]->line +||join words to make a line, inserting one space as separator +unwords = foldr1 (insert ' ') + +insert :: *->[*]->[*]->[*] +insert a x y = x ++ [a] ++ y + +breakon :: *->*->[[*]]->[[*]] +breakon c a x = []:x, if a=c + = (a:hd x):tl x, otherwise + +||These definitions of `words' and `unwords' are due to Richard Bird, see +||Bird and Wadler (1988), page 91. diff --git a/miralib/ex/kate.lit.m b/miralib/ex/kate.lit.m new file mode 100644 index 0000000..7deb3cc --- /dev/null +++ b/miralib/ex/kate.lit.m @@ -0,0 +1,138 @@ +\documentclass[10pt]{article} +\title{{\tt kate.lit.m} --- KaTify text} +\author{J. Cupitt} +\date{July 21st, 1989} +% turn off para indents +\setlength{\parindent}{0in} +% put some space between paras +\setlength{\parskip}{0.05in} +\begin{document} +\maketitle + +%An example of a Miranda literate script that is also a LaTeX source +%file. Note that the lines of formal program text are surrounded by +%LaTeX verbatim directives. Contributed by John Cupitt, of the +%University of Kent. + +There is a group on USENET called \verb"rec.music.gaffa", dedicated to the +singer Kate Bush. A running joke in this group is to pretend fanatical +devotion to Kate And Her Works --- this reaches an extreme form in some +posters, who capitalise all the Ks and Ts in their articles in reference both +to KaTe herself and to the Knights Templar. This Miranda\footnote{Miranda is a +trademark of Research Software Ltd.} script can be used as a {\sc +Unix}\footnote{UNIX is a trademark of AT\&T in the USA and other +countries.} filter to prepare your articles for posting to \verb"gaffa". +The main function is called \verb"kate" and is at the end. + +Do some simple maps on text. We do: + +\begin{center} +\begin{tabular}{rcl} + c,C,k & $\rightarrow $ & K \\ + t & $\rightarrow $ & T \\ + qu,Qu & $\rightarrow $ & Kw \\ + ck & $\rightarrow $ & K \\ + ch,Ch & $\rightarrow $ & Khe +\end{tabular} +\end{center} + +We also look for Kommon words that can be easily swapped for something with +more ks and ts. + +The dictionary we use to look for common words. This is very small at the +moment! I should perhaps find a thesaurus and fix this up properly. + +\begin{verbatim} + +> kateMap +> = [(["interpose", "insert"], +> "interject"), +> (["frequent", "general", "usual", "normal"], +> "common"), +> (["program", "file"], +> "script"), +> (["name"], +> "appelation"), +> (["however"], +> "though"), +> (["serve"], +> "officiate"), +> (["intersperse"], +> "punctuate") +> ] + +\end{verbatim} + +First map. Very easy! + +\begin{verbatim} + +> swapCase :: [char] -> [char] +> swapCase ('c':'k':x) = 'K':swapCase x +> swapCase ('c':'h':x) = 'K':'h':'e':swapCase x +> swapCase ('C':'h':x) = 'K':'h':'e':swapCase x +> swapCase ('c':x) = 'K':swapCase x +> swapCase ('C':x) = 'K':swapCase x +> swapCase ('k':x) = 'K':swapCase x +> swapCase ('t':x) = 'T':swapCase x +> swapCase ('q':'u':x) = 'K':'w':swapCase x +> swapCase ('Q':'u':x) = 'K':'w':swapCase x +> swapCase (a:x) = a: swapCase x +> swapCase [] = [] + +\end{verbatim} + +Second map. We loop down the input again, chopping out words. Each one gets +put through tryMap. + +\begin{verbatim} + +> swapWords :: [char] -> [char] +> swapWords [] = [] +> swapWords inp +> = punk ++ tryMap word ++ swapWords tail +> where +> punk = takewhile ((~) . letter) inp +> start = dropwhile ((~) . letter) inp +> word = takewhile letter start +> tail = dropwhile letter start + +\end{verbatim} + +Try to map a word through the KaTe thesaurus we defined earlier. We try to be +clever about what we swap. For example, we want \verb"insert" to be mapped to +\verb"interject", and \verb"inserting" to be mapped to \verb"interjecting". +This isn't always the most sensible way to do it \ldots + +\begin{verbatim} + +> tryMap :: [char] -> [char] +> tryMap word +> = word, if maps = [] +> = hd maps, otherwise +> where +> maps = [ to ++ drop (#x) word | +> (from, to) <- kateMap; x <- from; +> x $isprefix word ] + +\end{verbatim} + +Test for first argument a prefix of the second argument. + +\begin{verbatim} + +> isprefix :: [*] -> [*] -> bool +> isprefix a b = take (#a) b = a + +\end{verbatim} + +And our entry point. We just pipe stuff first through swapWords, then through +swapCase. + +\begin{verbatim} + +> kate :: [char] -> [char] +> kate = swapCase . swapWords + +\end{verbatim} +\end{document} diff --git a/miralib/ex/kate.pdf b/miralib/ex/kate.pdf Binary files differnew file mode 100644 index 0000000..606a4c8 --- /dev/null +++ b/miralib/ex/kate.pdf diff --git a/miralib/ex/kate.tex b/miralib/ex/kate.tex new file mode 120000 index 0000000..8da0f90 --- /dev/null +++ b/miralib/ex/kate.tex @@ -0,0 +1 @@ +kate.lit.m
\ No newline at end of file diff --git a/miralib/ex/keith.m b/miralib/ex/keith.m new file mode 100644 index 0000000..b743de9 --- /dev/null +++ b/miralib/ex/keith.m @@ -0,0 +1,31 @@ +> ||this tests that floating point overflow is handled correctly + +Date: Mon, 16 Apr 90 17:15:03 CST +From: mccrosky@ishmael.usask.ca + +Sorry for the delay in sending my bignum problem, I've been out of town. + +> keith n = (shownum n) ++ " " ++ (shownum ((log (sumterm n))/n)) where +> sumterm n = sum (map prodterm [0..entier (n/2)]) where +> prodterm p = prod (map term [0..p-1]) where +> term j = x*(x-1)/((p-j)^2) where +> x = n-(2*j) +> prod = foldr (*) 1 +> lim = lay (from 1) where from n = (keith n):(from (n*2)) + + +******** This is the execution: + (We believe the results up to n=256 are correct). + +Miranda lim +1 0.0 +2 0.549306144334 +4 0.736109744792 +8 0.876176116589 +16 0.966470019952 +32 1.021895160467 +64 1.054884461071 +128 1.07405223475 +256 1.084981322415 +512 +should trap floating point overflow here diff --git a/miralib/ex/makebug.m b/miralib/ex/makebug.m new file mode 100644 index 0000000..b32d4bb --- /dev/null +++ b/miralib/ex/makebug.m @@ -0,0 +1,18 @@ +> makebug size = [Tofile "/tmp/big.m" (big_def size)] +> big_def n = "big_list\n=[\n" ++ lay (rep n " \"hello\",") ++ " \"hello\"]\n" + +This tests garbage collection during compilation. First turn on gc +reports by saying + /gc + +To generate /tmp/big.m of chosen size say, e.g. + makebug 10000 +to get mira to compile the result say + /f /tmp/big +Saying this repeatedly (or /f %) will force recompilations +Or from the command line after quitting mira + rm /tmp/big.x #to force recompilation + mira -make -gc /tmp/big + +If the heap becomes corrupted you will see strange type errors or +"impossible event" messages. From Rick Morgan at Durham, May 1990. diff --git a/miralib/ex/matrix.m b/miralib/ex/matrix.m new file mode 100644 index 0000000..46abbaf --- /dev/null +++ b/miralib/ex/matrix.m @@ -0,0 +1,70 @@ +||very simple matrix package (DT) +||note that to include this in one of your own scripts, you can say +|| %include <ex/matrix> + +%export matrix idmat matadd matsub matmult scalmult mkrow mkcol det + adjoint inv + +matrix == [[num]] + +idmat :: num->matrix ||identity matrix of given size +idmat n = [[delta i j|j<-[1..n]]|i<-[1..n]] + where + delta i j = 1, if i=j + = 0, otherwise + +matadd :: matrix->matrix->matrix +matadd x y = map2 vadd x y + where + vadd x y = map2 (+) x y + +matsub :: matrix->matrix->matrix +matsub x y = map2 vsub x y + where + vsub = map2 (-) + +matmult :: matrix->matrix->matrix +matmult x y = outer inner x (transpose y) ||* +inner x y = sum (map2 (*) x y) +outer f x y = [[f a b|b<-y]|a<-x] + +||*note that transpose is already defined in the standard environment + +scalmult :: num->matrix->matrix ||multiply a matrix by a scalar +scalmult n x = map (map (*n)) x + +mkrow :: [num]->matrix ||make vector into matrix with a single row +mkrow x = [x] + +mkcol :: [num]->matrix ||make vector into matrix with a single column +mkcol x = map (:[]) x + +det :: matrix->num ||determinant, of square matrix +det [[a]] = a +det xs = sum [xs!0!i*cofactor 0 i xs|i<-index xs], if #xs=#xs!0 + = error "det of nonsquare matrix", otherwise +cofactor i j xs = (-1)^(i+j) * det (minor i j xs) +minor i j xs = [omit j x | x<-omit i xs] +omit i x = take i x ++ drop (i+1) x + +adjoint :: matrix->matrix ||adjoint, of square matrix +adjoint xs = transpose[[cofactor i j xs | j<-index xs] | i <- index xs] + +inv :: matrix->matrix ||inverse, of non-singular square matrix +inv xs = transpose[[cofactor i j xs/h | j<-index xs] | i <- index xs] + where + h = det xs +||The above is a literal transcription of the mathematical definition of +||matrix inverse. A less naive version of the package would rewrite +||this to use Gaussian elimination. + +||a few test matrices (these are not exported from the script, but will +||be in scope if this is your current script) +a = [[1,2],[3,4]] +b = [[1,1,1],[1,2,3],[2,4,8]] +c = [[0,1,2,3],[1,2,3,4],[2,3,4,0],[3,4,0,1]] +i2 = idmat 2 +i3 = idmat 3 +i4 = idmat 4 + +test = matmult b (inv b) diff --git a/miralib/ex/mrev b/miralib/ex/mrev new file mode 100755 index 0000000..85b3dc6 --- /dev/null +++ b/miralib/ex/mrev @@ -0,0 +1,22 @@ +#! /usr/bin/mira -exec +main :: [sys_message] +main = map f (tl $*), if # $* > 1 ||$* is equivalent to argv + = [Stdout (revlines $-)], otherwise ||no files, use stdin ($-) + +f :: [char]->sys_message +f fil = Stderr ("mrev: cannot open "++fil++"\n"), if badfile + = Stdout (revlines (read fil)), otherwise + where + badfile = ~ member (filemode fil) 'r' + +revlines :: [char]->[char] +revlines = lay.map reverse.lines + +||The usage of this command (from a UNIX shell) is +|| mrev [file] ... +||If no files given, takes data from stdin. This is a Miranda version +||of the UNIX command `rev' which reverses each line of its input. + +||This example is a template for turning any Miranda function of type +||[char]->[char] into a UNIX filter. Replace `revlines' in the above +||text, by your chosen function. diff --git a/miralib/ex/parafs.m b/miralib/ex/parafs.m new file mode 100644 index 0000000..be6af05 --- /dev/null +++ b/miralib/ex/parafs.m @@ -0,0 +1,33 @@ +||program for printing isomers of the alkanes -- D.A.Turner +||say `output' to run +mol ::= H | C[mol] ||new type -- alkane molecules and radicals +c p = C (sort p) ||place subcomponents in a standard order +molecules n = mkset [ mk_molecule x | x <- radicals n ] +mk_molecule(C p) = canonical_orientation (C(H:p)) +radicals 0 = [H] +radicals n = (map rads [1..])!(n-1) || make rads a memo function +rads n = mkset [ c[x,y,z] | i <- [0..(n-1)div 3]; j <- [i..(n-1-i)div 2]; + x <- radicals i; y <- radicals j; z <- radicals(n-1-i-j) ] +canonical_orientation x = min (closure reorientations [x]) +reorientations (C p) = [ invert (p--[x]) x | x <- p; x ~= H ] + where + invert p (C q) = c (c p:q) +output = concat (map out [1..]) +out n = title n ++ concat(map prettyprint (molecules n)) +title n = "isomers of " ++ prefix!(n-1) ++ "ane\n" +prefix = ["meth","eth","prop","but","pent","hex","hept","oct","non", + "dec"] ++ [show i++"-"|i<-[11..]] + +||below this line is concerned with drawing pictures of the molecules +%include "graphics.m" +prettyprint x = printpic1 (hd (molpics x)) ++ "\n" +molpics (C p) = compositions ([centre]:map f [1..# p] ) + where + f i = map (reflect (direction!(i-1))) (subpics i) + subpics i = [q1|q<-molpics (p!(i-1)); + q1<-shift(translate 1 0 q),shift q1..] +molpics H = [pic 0 0 ["H"]] +direction = [1,-1,0,2] +shift p = translate 1 0 (overlaypic[bond,p]) +bond = pic 0 0 ["-"] +centre = pic 0 0 ["C"] diff --git a/miralib/ex/polish.m b/miralib/ex/polish.m new file mode 100644 index 0000000..21e58a5 --- /dev/null +++ b/miralib/ex/polish.m @@ -0,0 +1,34 @@ +||very simple testbed for Miranda unification package, "unify.m" + +||The expressions to be unified here are strings written in (forward) +||polish notation, such as "*+12-xy" - meaning (1+2)*(x-y). The +||operators are + - * / with single letter variables, and single digit +||constants. We provide bindings for the free identifiers of "unify.m" +||corresponding to this syntax. + +%include "unify.m" + { expr==[char]; operator==char; var==char; + isvar=isvar; getvar=getvar; putvar=putvar; + rator=rator; rands=rands; construct=construct; + } + +isvar e = letter (hd e) +getvar = hd +putvar = (:[]) +rator = hd +rands (c:[]) = [], if digit c +rands (c:e) = [a,b], if member "+-*/" c & e2=[] + = error "illegal string", otherwise + where + (a,e1) = get e + (b,e2) = get e1 + get [] = error "illegal string" + get (c:x) = ([c],x), if letter c \/ digit c + = ([c]++a++b,x2), otherwise + where + (a,x1) = get x + (b,x2) = get x1 +construct c xs = c:concat xs + +test = unifyexprs "*+x3/7x" "*+1y/z1" ||the result should be "*+13/71" +test1 = unifyexprs "*+x3/7x" "*+1y/y1" ||not unifiable diff --git a/miralib/ex/powers.m b/miralib/ex/powers.m new file mode 100644 index 0000000..019a139 --- /dev/null +++ b/miralib/ex/powers.m @@ -0,0 +1,15 @@ +||prints a table of powers 2 to 5 of the numbers 1 to 20 +||to see the table, say +|| output + +output = title ++ captions ++ concat (map line [1..20]) + +title = cjustify 60 "A TABLE OF POWERS" ++ "\n\n" + +captions = format "N" ++ concat (map caption [2..5]) ++ "\n" + +caption i = format ("N^" ++ shownum i) + +format = rjustify 12 + +line n = concat [format (show(n^i)) | i<-[1..5]] ++ "\n" diff --git a/miralib/ex/primes.m b/miralib/ex/primes.m new file mode 100644 index 0000000..2a7c5df --- /dev/null +++ b/miralib/ex/primes.m @@ -0,0 +1,7 @@ +||The infinite list of all prime numbers, by the sieve of Eratosthenes. +||To see the list, just say `primes', or if you prefer +|| lay(map show primes) +||will print them one per line. Hit control-C (interrupt) to stop. + +primes = sieve[2..] +sieve (p:x) = p:sieve[n|n<-x;n mod p~=0] diff --git a/miralib/ex/pyths.m b/miralib/ex/pyths.m new file mode 100644 index 0000000..8301e47 --- /dev/null +++ b/miralib/ex/pyths.m @@ -0,0 +1,9 @@ +||Finds all pythagorean triangles (right triangles with integer sides) +||Note the use of a diagonalising list comprehension, with `//' instead +||of `|'. To see the triangles, say +|| output + +output = lay (map show pyths) +pyths = [(a, b, intsqrt (a*a+b*b)) // a <- [3..]; b<-[a+1..]; is_sq (a*a+b*b)] +intsqrt x = entier (sqrt x) +is_sq y = (intsqrt y) ^ 2 = y diff --git a/miralib/ex/queens.m b/miralib/ex/queens.m new file mode 100644 index 0000000..2ed5734 --- /dev/null +++ b/miralib/ex/queens.m @@ -0,0 +1,22 @@ +||this generates all solutions to the 8 queens problem -- say +|| solns +||and it will print the solutions one per line - all 92 of them. This +||is a good program for testing the garbage collector. Say `/gc' to +||switch on garbage collector diagnostics. + +solns = layn(map show (queens 8)) +queens 0 = [[]] +queens (n+1) = [q:b|b<-queens n;q<-[1..8];safe q b] +safe q b = and[~checks q b i|i<-index b] +checks q b i = q=b!i \/ abs(q-b!i)=i+1 + +||Note that the function `queens n' returns a list of all solutions to +||the n queens problem (placing queens in the first n columns of a chess +||board, so that no queen gives check to another). A board with n +||queens is represented as a list of n numbers, namely the positions of +||the queens in each column + +||This example exhibits a basic technique of lazy functional +||programming, which is to eliminate backtracking from a search problem +||by working at the level of a list of all solutions, rather than a +||single solution. diff --git a/miralib/ex/queens1.m b/miralib/ex/queens1.m new file mode 100644 index 0000000..79b52a8 --- /dev/null +++ b/miralib/ex/queens1.m @@ -0,0 +1,16 @@ +||This finds one solution to the eight queens problem, using a +||different method from that of the previous script, "queens.m". +||To run it, say +|| output +||This time the backtracking is programmed explicitly + +output = concat [c:shownum r++" "|(c,r)<-zip2 "rnbqkbnr" soln] +soln = until full extend emptyboard +extend board = until safe alter (addqueen board) +addqueen board = 1:board +emptyboard = [] +full board = # board=8 +alter (q:board) = q+1:board, if q<8 + = alter board, otherwise ||backtrack +safe (q:board) = and [~checks q board i|i<-index board] +checks q board i = q=board!i \/ abs(q-board!i)=i+1 diff --git a/miralib/ex/quicksort.m b/miralib/ex/quicksort.m new file mode 100644 index 0000000..2da7d55 --- /dev/null +++ b/miralib/ex/quicksort.m @@ -0,0 +1,12 @@ +||this is a functional version of quicksort, to see it work, say: +|| qsort testdata +||the reason we have to call the function `qsort' rather than `sort' is +||because there is a `sort' already defined in the standard environment + +qsort [] = [] +qsort (a:x) = qsort [b|b<-x;b<=a] ++ [a] ++ qsort[b|b<-x;b>a] + +testdata = f 10 +f n = concat(transpose [[0,2..2*n],[2*n-1,2*n-3..1]]) + +||note that the sort included in the standard environment is merge-sort diff --git a/miralib/ex/rational.m b/miralib/ex/rational.m new file mode 100644 index 0000000..8b432d1 --- /dev/null +++ b/miralib/ex/rational.m @@ -0,0 +1,56 @@ +||rational numbers as an abstract data type, say +|| %include <ex/rat> +||to include this in one of your own scripts. Quoting the filename in +||this form makes the %include directive work from any directory. + +abstype rational +with ratio :: num -> num -> rational + mkrat :: num->rational + rplus, rminus, rtimes, rdiv :: rational -> rational -> rational + rpow :: num -> rational -> rational + numerator, denominator :: rational -> num + rparts :: rational -> (num,num) + showrational :: rational -> [char] + +rational == (num,num) + +||a rational is represented as a pair of integers +||note that rationals are kept in their lowest terms, with positive +||denominator, and (0,1) is the unique representation of zero + +ratio p q = error "illegal ratio", if q=0\/~integer p\/~integer q + = ratio (-p) (-q), if q<0 + = (0,1), if p=0 + = (p div h,q div h), otherwise + where + h = hcf (abs p) q + hcf a b = hcf b a, if a>b + = b, if a=0 + = hcf (b mod a) a, otherwise + +mkrat n = ratio n 1, if integer n + = error ("mkrat "++shownum n), otherwise + +(a,b) $rplus (c,d) = ratio (a*d+c*b) (b*d) +(a,b) $rminus (c,d) = ratio (a*d-c*b) (b*d) +(a,b) $rtimes (c,d) = ratio (a*c) (b*d) +(a,b) $rdiv (c,d) = ratio (a*d) (b*c) + +rpow 0 x = (1,1) +rpow n x = thing, if n mod 2 = 0 + = x $rtimes thing, otherwise + where + thing = rpow (n div 2) (x $rtimes x) + +numerator = fst +denominator = snd +rparts = id + +showrational (a,b) = "(ratio "++shownum1 a++" "++shownum1 b++")" +shownum1 n = "("++shownum n++")", if n<0 + = shownum n, otherwise + +||Attempts to print a rational will automatically pick up the function +||called showrational - see manual section on abstract data types. Note +||that we have chosen to print rationals in such a way that Miranda can +||read them back in again at the same type. diff --git a/miralib/ex/refoliate.m b/miralib/ex/refoliate.m new file mode 100644 index 0000000..028f362 --- /dev/null +++ b/miralib/ex/refoliate.m @@ -0,0 +1,60 @@ +> tree ::= Leaf num | Fork tree tree + +PROBLEM: write down the definition of a function which takes a tree and +returns a tree of the SAME SHAPE, containing the same data, but with the +leaves moved around so that the data appears in ascending order, when +the tree is scanned from left to right. + +> reorder :: tree->tree +> reorder t = refoliate t (sort (fringe t)) + +Our idea here is that `fringe' extracts a list of all the data in the +tree, while `refoliate' takes a tree and a list of data, and replaces +the leaves of the tree with the given data, preserving the shape of the +tree. We define fringe first, as it is the easiest. + +> fringe :: tree->[num] +> fringe (Leaf n) = [n] +> fringe (Fork s t) = fringe s ++ fringe t + +Aside - there is a trivial change to the last line which alters the +behaviour of fringe so that the call to sort is no longer necessary. We +can replace `++' by a call to the library function `merge'. This would +improve the efficiency of the solution. + +We define `refoliate' in terms of an auxiliary function which takes a +subtree and the list of replacement data, and returns a pair - the +refoliated subtree, and the unused part of the list. + +> refoliate :: tree->[num]->tree +> refoliate t x = fst (refol t x) + +> refol :: tree->[num]->(tree,[num]) +> refol (Leaf n) (a:x) = (Leaf a,x) +> refol (Fork s t) x = (Fork s1 t1,x'') +> where +> (s1,x') = refol s x +> (t1,x'') = refol t x' + +Here is an example tree on which to call `reorder', to see that the +algorithm works. + +> t1 = mktree [19,0,17,2,15,4,13,6,11,8,9,10,7,12,5,14,3,16,1,18] + +mktree takes a list and builds a (well-balanced) tree from it. + +> mktree :: [num]->tree +> mktree [] = error "cannot have empty tree" +> mktree [a] = Leaf a +> mktree x = Fork (mktree (take n x)) (mktree (drop n x)) +> where n = # x div 2 + +Finally, we define a function same_shape, which can be used to confirm +that reorder holds the shape constant. + +> same_shape :: tree->tree->bool +> same_shape (Leaf a) (Leaf b) = True +> same_shape (Fork s t) (Fork s1 t1) = same_shape s s1 & same_shape t t1 +> same_shape s t = False ||all other cases + +> test = same_shape t1 (reorder t1) diff --git a/miralib/ex/selflines.m b/miralib/ex/selflines.m new file mode 100644 index 0000000..cf3d016 --- /dev/null +++ b/miralib/ex/selflines.m @@ -0,0 +1,32 @@ +||this produces an endless self describing scroll of lines, as follows +|| the 1st line is +|| "the 1st line is" +|| the 2nd line is +|| ""the 1st line is"" +|| the 3rd line is +|| "the 2nd line is" +|| etc... +||To see the result, say +|| output +||Hit control-C (interrupt) when you have seen enough. +||If you would like to send the output to a file, say +|| output &> fil +||where `fil' is the name of the file in which you want to put it +||this will create a background job + +output = concat[l++"\n"|l<-selflines] + +selflines = mklines 1 + +mklines n = ("the "++ord n++" line is:"): + ("\""++selflines!(n-1)++"\""): + mklines(n+1) + +ord n = show n++suffix n + +suffix 1 = "st" +suffix 2 = "nd" +suffix 3 = "rd" +suffix n = "th", if n=0 \/ 3<=n&n<=9 + = "th", if (n mod 100)div 10 = 1 ||because of 11,12,13 + = suffix(n mod 10), otherwise diff --git a/miralib/ex/set.m b/miralib/ex/set.m new file mode 100644 index 0000000..c6a52f9 --- /dev/null +++ b/miralib/ex/set.m @@ -0,0 +1,64 @@ +||definition of finite sets as an abstract data type, say +|| %include <ex/set> +||to include this in one of your own scripts. + +abstype set * +with makeset::[*]->set * ||converts list to set + enum::set *->[*] ||converts set to list + empty::set * ||empty set + mem::set *->*->bool ||does set contain element? + pincludes,includes::set *->set *->bool ||(proper) set inclusion + union::[set *]->set * ||union of a list of sets + intersect::[set *]->set * ||intersection of a list of sets + setdiff::set *->set *->set * ||set difference of two sets + union2::set *->set *->set * ||union of two sets + intersect2::set *->set *->set * ||intersection of two sets + add1::*->set *->set * ||add a single element to a set + sub1::*->set *->set * ||remove an element from a set (if present) + pick::set *->* ||pick some element from a set + rest::set *->set * ||remainder of set, without element got by pick + showset::(*->[char])->set *->[char] ||to make sets printable + +set * == [*] ||a set is represented as a list without duplicates +makeset = uniq.sort ||for efficiency the lists are kept sorted +enum = id +empty = [] +mem (a:x) b = a=b \/ a<b & mem x b +mem [] b = False +includes x y = (setdiff y x = []) +pincludes x y = x~=y & (setdiff y x = []) +union2 x y = uniq(merge x y) +union = foldr union2 empty +setdiff (a:x) (b:y) = a:setdiff x (b:y), if a<b + = setdiff (a:x) y, if a>b + = setdiff x y, otherwise +setdiff x y = x +intersect2 (a:x) (b:y) = intersect2 x (b:y), if a<b + = intersect2 (a:x) y, if a>b + = a : intersect2 x y, otherwise +intersect2 x y = [] +intersect = foldl1 intersect2 +add1 a (b:x) = a:b:x, if a<b + = b:x, if a=b + = b:add1 a x, otherwise +add1 a [] = [a] +sub1 a (b:x) = b:x, if a<b + = x, if a=b + = b:sub1 a x, otherwise +sub1 a [] = [] +pick (a:x) = a +pick [] = error "pick empty" +rest (a:x) = x +rest [] = error "pick empty" +showset f [] = "{}" +showset f (a:x) = "{"++f a++concat(map g x)++"}" + where + g a = ',':f a + +%export -uniq +||we have used the following auxiliary function, which removes adjacent +||duplicates from a list (this is not exported from the script) +uniq::[*]->[*] +uniq (a:b:x) = uniq (a:x), if a=b + = a:uniq (b:x), otherwise +uniq x = x diff --git a/miralib/ex/stack.m b/miralib/ex/stack.m new file mode 100644 index 0000000..d7a1af2 --- /dev/null +++ b/miralib/ex/stack.m @@ -0,0 +1,19 @@ +||This script defines stack, as an abstract data type based on lists. +||Note that there is a show function for stacks, causing them to print +||in a sensible way. + +abstype stack * +with empty::stack *; push::*->stack *->stack *; + pop::stack *->stack *; top::stack *->*; isempty::stack *->bool; + showstack::(*->[char])->stack *->[char] + +stack * == [*] +empty = [] +push a x = a:x +pop(a:x) = x +top(a:x) = a +isempty x = (x=[]) +showstack f [] = "empty" +showstack f (a:x) = "(push " ++ f a ++ " " ++ showstack f x ++ ")" + +teststack = push 1(push 2(push 3 empty)) diff --git a/miralib/ex/topsort.m b/miralib/ex/topsort.m new file mode 100644 index 0000000..88e96ee --- /dev/null +++ b/miralib/ex/topsort.m @@ -0,0 +1,32 @@ +||Miranda programming example - topological sort +topsort :: [(*,*)] -> [*] + +||topsort takes a list of pairs representing a partial order - where +||the presence of (u,v) in the list means that u precedes v in the +||ordering - and returns a total ordering consistent with the +||information given - that is if (u,v) is in the input data, then u will +||come before v in the output list. + +topsort rel = tsort (carrier rel) rel +||the carrier of a relation is the set of all the elements related by it + +tsort c r = [], if c=[] + = error "inconsistent data for tsort", if m=[] + = a : tsort (c--[a]) [(u,v)|(u,v)<-r; u~=a], otherwise + where + a = hd m + m = (c -- ran r) +||remarks on the above +|| - it is an invariant that c contains the carrier of relation r +|| - m is the set of elements of c with no predecessor in r + +||the error case will arise if the input data contains a cycle - i.e. +||if there is an element that directly or indirectly precedes itself. + +||a set is here represented as a list without duplicates +||the standard function mkset removes duplicates from a list + +dom r = mkset [u|(u,v)<-r] ||domain of a relation +ran r = mkset [v|(u,v)<-r] ||range of a relation +carrier r = union (dom r) (ran r) +union x y = mkset (x++y) diff --git a/miralib/ex/treesort.m b/miralib/ex/treesort.m new file mode 100644 index 0000000..e5b946b --- /dev/null +++ b/miralib/ex/treesort.m @@ -0,0 +1,20 @@ +|| Here is another sorting algorithm, this time treesort. +|| to try it out, say: treesort testdata + +tree * ::= NILT | NODE * (tree *) (tree *) + +treesort = flatten.build + +build::[*]->tree * +build = foldr insert NILT + +insert b NILT = NODE b NILT NILT +insert b (NODE a x y) = NODE a (insert b x) y, if b<=a + = NODE a x (insert b y), if b>a + +flatten::tree *->[*] +flatten NILT = [] +flatten (NODE a x y) = flatten x ++ [a] ++ flatten y + +testdata = [1..5]++[20,19..16]++[6..10]++[15,14..11] + diff --git a/miralib/ex/unify.m b/miralib/ex/unify.m new file mode 100644 index 0000000..1ce4034 --- /dev/null +++ b/miralib/ex/unify.m @@ -0,0 +1,79 @@ +||Package for doing (first order) unification, parameterised on an +||abstract theory of expressions. (DT) + +||see the file <ex/polish> for an example of the use of this package. + +%free { expr,operator,var::type; + isvar::expr->bool; getvar::expr->var; putvar::var->expr; + rator::expr->operator; rands::expr->[expr]; + construct::operator->[expr]->expr; + } + +||Our theory of expressions is as follows - an expression is either a +||variable, or else it consists of a rator together with a list of +||rands. So for example a constant will be viewed as a rator which has +||an empty list of rands. The nature of variables, and the collection +||of possible rators and their arities, is determined at %include time. +||This enables us to use the same code for performing unification in +||quite different object languages. + +||for each e::expr, one of the following propositions will be true +||either isvar e & e = putvar(getvar e) +||or ~isvar e & e = construct(rator e)(rands e) + +%export unifyexprs unify ult q + +q * ::= FAIL | SUCCEED * ||useful type operator + +unifyexprs :: expr->expr->q expr ||convenient for testing + +unify :: subst->expr->expr->q subst + +||this implements the unification algorithm - it takes a substition +||(mapping from variables to expressions) and a pair of expressions, and +||returns the least extension of the substitution under which the +||expressions become the same - or FAIL if there is none. + +ult :: subst->expr->expr + +||computes the result of applying a substitution to an expression. + +unifyexprs x y = f(unify [] x y) + where + f FAIL = FAIL + f (SUCCEED s) = SUCCEED (ult s x) + ||note that (ult s y) = (ult s y) + ||if the unification succeeds + +subst == [(var,expr)] + +||We represent a substitution as a list of variable-expression pairs. +||The representation is lazy, in the sense that the expressions may +||contain occurrences of the variables in the domain of the substitution +||- this is taken care of in the definition of ult. + +unify s x y + = unifier s (ult s x) (ult s y) + where + unifier s x y = SUCCEED s, if x=y + = SUCCEED((getvar x,y):s), if isvar x & ~occurs x y + = SUCCEED((getvar y,x):s), if isvar y & ~occurs y x + = unifylist (SUCCEED s) (rands x) (rands y), + if ~isvar x & ~isvar y & conforms x y + = FAIL, otherwise + unifylist qs [] [] = qs + unifylist (SUCCEED s) (a:x) (b:y) = unifylist (unify s a b) x y + unifylist FAIL x y = FAIL + +ult s x = lookup s (getvar x), if isvar x + = construct(rator x)(map (ult s) (rands x)), otherwise + where + lookup [] a = putvar a + lookup ((a,y):t) a = ult s y ||note recursive call of ult + lookup ((b,y):t) a = lookup t a + +occurs y x || does subexpression y occur in formula x ? + = x=y, if isvar x + = or (map (occurs y) (rands x)), otherwise + +conforms x y = rator x = rator y & #rands x = #rands y |