new files

Task/Forest-fire/Sather/forest-fire.sa

@@ -0,0 +1,196 @@
+class FORESTFIRE is
+  private attr fields:ARRAY{ARRAY{INT}};
+  private attr swapu:INT;
+  private attr rnd:RND;
+  private attr verbose:BOOL;
+  private attr generation:INT;
+  readonly attr width, height:INT;
+  const empty:INT := 0;
+  const tree:INT := 1;
+  const burning:INT := 2;
+
+  attr prob_tree, prob_p, prob_f :FLT;
+
+  create(w, h:INT, v:BOOL):SAME is
+    res:FORESTFIRE := new;
+    res.fields := #(2);
+    res.fields[0] := #(w*h);
+    res.fields[1] := #(w*h);
+    res.width := w; res.height := h;
+    res.swapu := 0;
+    res.prob_tree := 0.55;
+    res.prob_p := 0.001;
+    res.prob_f := 0.00001;
+    res.rnd := #RND;
+    res.verbose := v;
+    res.generation := 0;
+    res.initfield;
+    return res;
+  end;
+
+  -- to give variability
+  seed(i:INT) is
+    rnd.seed(i);
+  end;
+
+  create(w, h:INT):SAME is
+    res ::= create(w, h, false);
+    return res;
+  end;
+
+  initfield is
+    n ::= 0;
+    swapu := 0;
+    if verbose and generation > 0 then
+      #ERR + "Previous generation " + generation + "\n";
+    end;
+    generation := 0;
+    loop i ::= 0.upto!(width-1);
+      loop j ::= 0.upto!(height-1);
+        if rnd.uniform > prob_tree.fltd then
+          cset(i, j, empty);
+        else
+	  n := n + 1;
+          cset(i, j, tree);
+        end;
+      end;
+    end;
+    if verbose then
+      #ERR + #FMT("Field size is %dx%d (%d)", width, height, size) + "\n";
+      #ERR + "There are " + n + " trees (" + (100.0*n.flt/size.flt) + "%)\n";
+      #ERR + "prob_tree = " + prob_tree + "\n";
+      #ERR + "prob_f = " + prob_f + "\n";
+      #ERR + "prob_p = " + prob_p + "\n";
+      #ERR + "ratio = " + prob_p/prob_f + "\n";
+    end;
+  end;
+
+  field:ARRAY{INT} is
+    return fields[swapu];
+  end;
+
+  ofield:ARRAY{INT} is
+    return fields[swapu.bxor(1)];
+  end;
+
+  size:INT is
+    return width*height;
+  end;
+
+  set(i, j, t:INT)
+    pre bcheck(i, j)
+  is
+    ofield[j*width + i] := t;
+  end;
+
+  cset(i, j, t:INT)
+    pre bcheck(i, j)
+  is
+    field[j*width + i] := t;
+  end;
+
+  private bcheck(i, j:INT):BOOL is
+    if i.is_between(0, width-1) and j.is_between(0, height-1) then
+      return true; -- is inside
+    else
+      return false; -- is outside
+    end;
+  end;
+
+  get(i, j:INT):INT is
+    if ~bcheck(i, j) then
+      return empty;
+    end;
+    return field[j*width + i];
+  end;
+
+  oget(i, j:INT):INT is
+    if ~bcheck(i, j) then
+      return empty;
+    end;
+    return ofield[j*width + i];
+  end;
+
+  burning_neighbor(i, j:INT):BOOL is
+    loop x ::= (-1).upto!(1);
+      loop y ::= (-1).upto!(1);
+        if x /= y then
+          if get(i+x, j+y) = burning then return true; end;
+        end;
+      end;
+    end;
+    return false;
+  end;
+
+  evolve is
+    bp ::= 0;
+    loop i ::= 0.upto!(width-1);
+      loop j ::= 0.upto!(height-1);
+	case get(i, j)
+        when burning then set(i, j, empty); bp := bp + 1;
+        when empty then
+          if rnd.uniform > prob_p.fltd then
+            set(i, j, empty);
+          else
+            set(i, j, tree);
+          end;
+        when tree then
+          if burning_neighbor(i, j) then
+            set(i, j, burning);
+          else
+            if rnd.uniform > prob_f.fltd then
+              set(i, j, tree);
+            else
+              set(i, j, burning);
+            end;
+          end;
+        else
+          #ERR + "corrupted field\n";
+        end;
+      end;
+    end;
+    generation := generation + 1;
+    if verbose then
+      if bp > 0 then
+        #ERR + #FMT("Burning at gen %d: %d\n", generation-1, bp);
+      end;
+    end;
+    swapu := swapu.bxor(1);
+  end;
+
+  str:STR is
+    s ::= "";
+    loop j ::= 0.upto!(height -1);
+      loop i ::= 0.upto!(width -1);
+        case get(i, j)
+          when empty then s := s + ".";
+          when tree then s := s + "Y";
+          when burning then s := s + "*";
+        end;
+      end;
+      s := s + "\n";
+    end;
+    s := s + "\n";
+    return s;
+  end;
+
+end;
+
+class MAIN is
+
+  main is
+    forestfire ::= #FORESTFIRE(74, 40);
+    -- #FORESTFIRE(74, 40, true) to have some extra info
+    -- (redirecting stderr to a file is a good idea!)
+
+    #OUT + forestfire.str;
+    -- evolve 1000 times
+    loop i ::= 1000.times!;
+      forestfire.evolve;
+      -- ANSI clear screen sequence
+      #OUT + 0x1b.char + "[H" + 0x1b.char + "[2J";
+      #OUT + forestfire.str;
+    end;
+  end;
+
+end;