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