1 2(********************************************************************) 3(* *) 4(* fannkuch.sd7 Fannkuch-redux benchmark program *) 5(* Copyright (C) 2011 Bart C *) 6(* *) 7(* This program is free software; you can redistribute it and/or *) 8(* modify it under the terms of the GNU General Public License as *) 9(* published by the Free Software Foundation; either version 2 of *) 10(* the License, or (at your option) any later version. *) 11(* *) 12(* This program is distributed in the hope that it will be useful, *) 13(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 15(* GNU General Public License for more details. *) 16(* *) 17(* You should have received a copy of the GNU General Public *) 18(* License along with this program; if not, write to the *) 19(* Free Software Foundation, Inc., 51 Franklin Street, *) 20(* Fifth Floor, Boston, MA 02110-1301, USA. *) 21(* *) 22(* For maximum performance compile this program with: *) 23(* s7c -O2 -r fannkuch *) 24(* *) 25(********************************************************************) 26 27 28$ include "seed7_05.s7i"; 29 include "stdio.s7i"; 30 31const proc: fannkuch (in integer:n, inout integer:res, inout integer:res2) is func 32 local 33 var integer: signx is 1; 34 var integer: maxflips is 0; 35 var integer: flips is 0; 36 var integer: sum is 0; 37 var integer: i is 0; 38 var integer: j is 0; 39 var integer: t is 0; 40 var integer: q1 is 0; 41 var integer: qq is 0; 42 var integer: sx is 0; 43 var boolean: finished is FALSE; 44 var array integer: p is 0 times 0; 45 var array integer: q is 0 times 0; 46 var array integer: s is 0 times 0; 47 begin 48 49 p := n times 0; 50 q := n times 0; 51 s := n times 0; 52 53 for i range 1 to n do 54 p[i]:=i; 55 q[i]:=i; 56 s[i]:=i; 57 end for; 58 59 repeat 60 q1:=p[1]; 61 62 if q1<>1 then 63 for i range 2 to n do q[i]:=p[i] end for; 64 flips:=1; 65 66 qq:=q[q1]; 67 while qq<>1 do 68 q[q1]:=q1; 69 if q1>=4 then 70 i:=2; j:=pred(q1); 71 repeat 72 t:=q[i]; q[i]:=q[j]; q[j]:=t; 73 incr(i); 74 decr(j); 75 until i>=j 76 end if; 77 q1:=qq; 78 incr(flips); 79 qq:=q[q1]; 80 end while; 81 sum+:=signx*flips; 82 if flips>maxflips then maxflips:=flips end if; 83 84 end if; 85 86 if signx=1 then 87 t:=p[1]; p[1]:=p[2]; p[2]:=t; 88 signx:=(-1); 89 else 90 t:=p[2]; p[2]:=p[3]; p[3]:=t; 91 signx:=1; 92 for i range 3 to n do 93 sx:=s[i]; 94 if sx<>1 then 95 s[i]:=pred(sx); 96 i:=succ(n); 97 else 98 if i=n then 99 res:=sum; 100 res2:=maxflips; 101 finished:=TRUE; 102 else 103 s[i]:=i; 104 t:=p[1]; 105 for j range 1 to i do 106 p[j]:=p[succ(j)]; 107 end for; 108 p[succ(i)]:=t; 109 end if; 110 end if; 111 end for; 112 end if; 113 until finished; 114 115 end func; 116 117 118const proc: main is func 119 local 120 var integer: n is 0; 121 var integer: sum is 0; 122 var integer: flips is 0; 123 begin 124 125 n:=10; 126 fannkuch(n,sum,flips); 127 128 writeln(sum); 129 writeln("Fannkuch(" <& n <& ") =" <& flips); 130 end func; 131