## SCff.gp 1/14/17 aev
## Plotting Sierpinski carpet fractal.
## dat-files are PARI/GP generated output files:
## http://rosettacode.org/wiki/Sierpinski_carpet#PARI.2FGP
#cd 'C:\gnupData'

##SC5
clr = '"green"'
filename = "SC5gp1"
ttl = "Sierpinski carpet fractal, v.#1"
load "plotff.gp"


extern crate crypto;

use crypto::digest::Digest;
use crypto::sha2::Sha256;
use std::fs::File;
use std::io::prelude::*;
use std::io::BufReader;

fn sha256_merkle_tree(filename: &str, block_size: usize) -> std::io::Result<Option<Vec<u8>>> {
    let mut md = Sha256::new();
    let mut input = BufReader::new(File::open(filename)?);
    let mut buffer = vec![0; block_size];
    let mut digest = vec![0; md.output_bytes()];
    let mut digests = Vec::new();
    loop {
        let bytes = input.read(&mut buffer)?;
        if bytes == 0 {
            break;
        }
        md.reset();
        md.input(&buffer[0..bytes]);
        md.result(&mut digest);
        digests.push(digest.clone());
    }
    let mut len = digests.len();
    if len == 0 {
        return Ok(None);
    }
    while len > 1 {
        let mut j = 0;
        let mut i = 0;
        while i < len {
            if i + 1 < len {
                md.reset();
                md.input(&digests[i]);
                md.input(&digests[i + 1]);
                md.result(&mut digests[j]);
            } else {
                digests.swap(i, j);
            }
            i += 2;
            j += 1;
        }
        len = j;
    }
    Ok(Some(digests[0].clone()))
}

fn digest_to_string(digest: &[u8]) -> String {
    let mut result = String::new();
    for x in digest {
        result.push_str(&format!("{:02x}", x));
    }
    result
}

fn main() {
    match sha256_merkle_tree("title.png", 1024) {
        Ok(Some(digest)) => println!("{}", digest_to_string(&digest)),
        Ok(None) => {}
        Err(error) => eprintln!("I/O error: {}", error),
    }
}


import "io" for File
import "/crypto" for Sha256, Bytes
import "/seq" for Lst
import "/str" for Str
import "/fmt" for Conv

var bytes = File.read("title.png").bytes.toList
var chunks = Lst.chunks(bytes, 1024)
var hashes = List.filled(chunks.count, null)
var i = 0
for (chunk in chunks) {
   var h = Sha256.digest(chunk.map { |b| String.fromByte(b) }.join())
   hashes[i] = Str.chunks(h, 2).map { |x| Conv.atoi(x, 16) }.toList
   i = i + 1
}

var buffer = List.filled(64, 0)
while (hashes.count > 1) {
    var hashes2 = []
    var i = 0
    while (i < hashes.count) {
        if (i < hashes.count - 1) {
            for (j in  0..31) buffer[j] = hashes[i][j]
            for (j in  0..31) buffer[j+32] = hashes[i+1][j]
            var h = Sha256.digest(buffer.map { |b| String.fromByte(b) }.join())
            var hb = Str.chunks(h, 2).map { |x| Conv.atoi(x, 16) }.toList
            hashes2.add(hb)
        } else {
            hashes2.add(hashes[i])
        }
        i = i + 2
    }
    hashes = hashes2
}
System.print(Bytes.toHexString(hashes[0]))


// version 1.1.2

fun a(v: Boolean): Boolean {
    println("'a' called")
    return v
}

fun b(v: Boolean): Boolean {
    println("'b' called")
    return v
}

fun main(args: Array<String>){
    val pairs = arrayOf(Pair(true, true), Pair(true, false), Pair(false, true), Pair(false, false))
    for (pair in pairs) {
        val x = a(pair.first) && b(pair.second)
        println("${pair.first} && ${pair.second} = $x")
        val y = a(pair.first) || b(pair.second)
        println("${pair.first} || ${pair.second} = $y")
        println()
    }
}


{def A {lambda {:bool} :bool}}  -> A
{def B {lambda {:bool} :bool}}  -> B

{and {A true} {B true}}   -> true
{and {A true} {B false}}  -> false
{and {A false} {B true}}  -> false
{and {A false} {B false}} -> false

{or {A true} {B true}}    -> true
{or {A true} {B false}}   -> true
{or {A false} {B true}}   -> true
{or {A false} {B false}}  -> false


package main

import (
    "fmt"
    "strings"
    "unicode/utf8"
)

var order = 3
var grain = "#"

func main() {
    carpet := []string{grain}
    for ; order > 0; order-- {
        // repeat expression allows for multiple character
        // grain and for multi-byte UTF-8 characters.
        hole := strings.Repeat(" ", utf8.RuneCountInString(carpet[0]))
        middle := make([]string, len(carpet))
        for i, s := range carpet {
            middle[i] = s + hole + s
            carpet[i] = strings.Repeat(s, 3)
        }
        carpet = append(append(carpet, middle...), carpet...)
    }
    for _, r := range carpet {
        fmt.Println(r)
    }
}


def base3 = { BigInteger i -> i.toString(3) }

def sierpinskiCarpet = { int order ->
    StringBuffer sb = new StringBuffer()
    def positions = 0..<(3**order)
    def digits = 0..<([order,1].max())

    positions.each { i ->
        String i3 = base3(i).padLeft(order, '0')

        positions.each { j ->
            String j3 = base3(j).padLeft(order, '0')

            sb << (digits.any{ i3[it] == '1' && j3[it] == '1' } ? '  ' : order.toString().padRight(2) )
        }
        sb << '\n'
    }
    sb.toString()
}


print "AND"
for i = 0 to 1
    for j = 0 to 1
        print "a("; i; ") AND b( "; j; ")"
        res =a( i)    'call always
        if res <>0 then  'short circuit if 0
            res = b( j)
        end if
        print "=>",res
    next
next

print "---------------------------------"
print "OR"
for i = 0 to 1
    for j = 0 to 1
        print "a("; i; ") OR b("; j; ")"
        res =a( i)    'call always
        if res = 0 then  'short circuit if <>0
            res = b( j)
        end if
        print "=>", res
    next
next

'----------------------------------------
function a( t)
    print ,"calls func a"
    a = t
end function

function b( t)
    print ,"calls func b"
    b = t
end function


global outcome
function a bool
    put "a called with" && bool & cr after outcome
    return bool
end a
function b bool
    put "b called with" && bool & cr after outcome
    return bool
end b

on mouseUp
    local tExp
    put empty into outcome
    repeat for each item op in "and,or"
        repeat for each item x in "true,false"
            put merge("a([[x]]) [[op]] b([[x]])") into tExp
            put merge(tExp && "is [[" & tExp & "]]") & cr after outcome
            put merge("a([[x]]) [[op]] b([[not x]])") into tExp
            put merge(tExp && "is [[" & tExp & "]]") & cr after outcome
        end repeat
        put cr after outcome
    end repeat
    put outcome
end mouseUp


inCarpet :: Int -> Int -> Bool
inCarpet 0 _ = True
inCarpet _ 0 = True
inCarpet x y = not ((xr == 1) && (yr == 1)) && inCarpet xq yq
  where ((xq, xr), (yq, yr)) = (x `divMod` 3, y `divMod` 3)

carpet :: Int -> [String]
carpet n = map
            (zipWith
              (\x y -> if inCarpet x y then '#' else ' ')
              [0..3^n-1]
             . repeat)
            [0..3^n-1]

printCarpet :: Int -> IO ()
printCarpet = mapM_ putStrLn . carpet


$define FILLER "*"  # the filler character

procedure main(A)

   width := 3 ^ ( order := (0 < \A[1]) | 3 )
   write("Carpet order= ",order)

   every !(canvas := list(width)) := list(width," ")        # prime the canvas

   every y := 1 to width & x := 1 to width do               # traverse it
      if IsFilled(x-1,y-1) then canvas[x,y] := FILLER       # fill

   every x := 1 to width & y := 1 to width do
      writes((y=1,"\n")|"",canvas[x,y]," ")                 # print
end

procedure IsFilled(x,y)                      #  succeed if x,y should be filled
   while  x ~= 0 & y ~= 0 do {
      if x % 3 = y %3 = 1 then fail
      x /:= 3
      y /:=3
      }
   return
end


function a(i)
    print "Function a(i) called."
    return i
end

function b(i)
    print "Function b(i) called."
    return i
end

i = true
x = a(i) and b(i);  print ""
y = a(i) or  b(i);  print ""

i = false
x = a(i) and b(i);  print ""
y = a(i) or  b(i)


a := proc(bool)
	printf("a is called->%s\n", bool):
	return bool:
end proc:
b := proc(bool)
	printf("b is called->%s\n", bool):
	return bool:
end proc:
for i in [true, false] do
	for j in [true, false] do
		printf("calculating	x := a(i) and b(j)\n"):
		x := a(i) and b(j):
		printf("calculating	x := a(i) or b(j)\n"):
		y := a(i) or  b(j):
	od:
od:


sierpinskiCarpet := method(n,
    carpet := list("@")
    n repeat(
        next := list()
        carpet foreach(s, next append(s .. s .. s))
        carpet foreach(s, next append(s .. (s asMutable replaceSeq("@"," ")) .. s))
        carpet foreach(s, next append(s .. s .. s))
        carpet = next
    )
    carpet join("\n")
)

sierpinskiCarpet(3) println


public static boolean inCarpet(long x, long y) {
    while (x!=0 && y!=0) {
        if (x % 3 == 1 && y % 3 == 1)
            return false;
        x /= 3;
        y /= 3;
    }
    return true;
}

public static void carpet(final int n) {
    final double power = Math.pow(3,n);
    for(long i = 0; i < power; i++) {
        for(long j = 0; j < power; j++) {
            System.out.print(inCarpet(i, j) ? "*" : " ");
        }
        System.out.println();
    }
}


a[in_] := (Print["a"]; in)
b[in_] := (Print["b"]; in)
a[False] && b[True]
a[True] || b[False]


  function x=a(x)
    printf('a: %i\n',x);
  end;
  function x=b(x)
    printf('b: %i\n',x);
  end;

  a(1) && b(1)
  a(0) && b(1)
  a(1) || b(1)
  a(0) || b(1)


MODULE ShortCircuit;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT WriteString,WriteLn,ReadChar;

PROCEDURE a(v : BOOLEAN) : BOOLEAN;
VAR buf : ARRAY[0..63] OF CHAR;
BEGIN
    FormatString("    # Called function a(%b)\n", buf, v);
    WriteString(buf);
    RETURN v
END a;

PROCEDURE b(v : BOOLEAN) : BOOLEAN;
VAR buf : ARRAY[0..63] OF CHAR;
BEGIN
    FormatString("    # Called function b(%b)\n", buf, v);
    WriteString(buf);
    RETURN v
END b;

PROCEDURE Print(x,y : BOOLEAN);
VAR buf : ARRAY[0..63] OF CHAR;
VAR temp : BOOLEAN;
BEGIN
    FormatString("a(%b) AND b(%b)\n", buf, x, y);
    WriteString(buf);
    temp := a(x) AND b(y);

    FormatString("a(%b) OR b(%b)\n", buf, x, y);
    WriteString(buf);
    temp := a(x) OR b(y);

    WriteLn;
END Print;

BEGIN
    Print(FALSE,FALSE);
    Print(FALSE,TRUE);
    Print(TRUE,TRUE);
    Print(TRUE,FALSE);
    ReadChar
END ShortCircuit.


<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">

<meta http-equiv="Content-Type" content="text/html;charset=utf-8">
<title>Sierpinski Carpet</title>


SSEVAL1(IN)
 WRITE !,?10,$STACK($STACK,"PLACE")
 QUIT IN
SSEVAL2(IN)
 WRITE !,?10,$STACK($STACK,"PLACE")
 QUIT IN
SSEVAL3
 NEW Z
 WRITE "1 AND 1"
 SET Z=$$SSEVAL1(1) SET:Z Z=Z&$$SSEVAL2(1)
 WRITE !,$SELECT(Z:"TRUE",1:"FALSE")
 WRITE !!,"0 AND 1"
 SET Z=$$SSEVAL1(0) SET:Z Z=Z&$$SSEVAL2(1)
 WRITE !,$SELECT(Z:"TRUE",1:"FALSE")
 WRITE !!,"1 OR 1"
 SET Z=$$SSEVAL1(1) SET:'Z Z=Z!$$SSEVAL2(1)
 WRITE !,$SELECT(Z:"TRUE",1:"FALSE")
 WRITE !!,"0 OR 1"
 SET Z=$$SSEVAL1(0) SET:'Z Z=Z!$$SSEVAL2(1)
 WRITE !,$SELECT(Z:"TRUE",1:"FALSE")
 KILL Z
 QUIT


def short_and(bool1, bool2)
    global a
    global b
    if a(bool1)
        if b(bool2)
            return true
        else
            return false
        end
    else
        return false
    end
end

def short_or(bool1, bool2)
    if a(bool1)
        return true
    else
        if b(bool2)
            return true
        else
            return false
        end
    end
end

def a(bool)
    println "a called."
    return bool
end

def b(bool)
    println "b called."
    return bool
end

println "F and F = " + short_and(false, false) + "\n"
println "F or F  = " + short_or(false, false)  + "\n"

println "F and T = " + short_and(false, true)  + "\n"
println "F or T  = " + short_or(false, true)   + "\n"

println "T and F = " + short_and(true, false)  + "\n"
println "T or F  = " + short_or(true, false)   + "\n"

println "T and T = " + short_and(true, true)   + "\n"
println "T or T  = " + short_or(true, true)    + "\n"


using System.Console;

class ShortCircuit
{
    public static a(x : bool) : bool
    {
        WriteLine("a");
        x
    }

    public static b(x : bool) : bool
    {
        WriteLine("b");
        x
    }

    public static Main() : void
    {
        def t = true;
        def f = false;

        WriteLine("True  && True : {0}", a(t) && b(t));
        WriteLine("True  && False: {0}", a(t) && b(f));
        WriteLine("False && True : {0}", a(f) && b(t));
        WriteLine("False && False: {0}", a(f) && b(f));
        WriteLine("True  || True : {0}", a(t) || b(t));
        WriteLine("True  || False: {0}", a(t) || b(f));
        WriteLine("False || True : {0}", a(f) || b(t));
        WriteLine("False || False: {0}", a(f) || b(f));
    }
}


/* NetRexx */
options replace format comments java crossref symbols nobinary

Parse Version v
Say 'Version='v

If a()  | b() Then Say 'a and b are true'
If \a() | b() Then Say 'Surprise'
Else               Say 'ok'

If a(),  b() Then Say 'a is true'
If \a(), b() Then Say 'Surprise'
Else              Say 'ok: \\a() is false'

Select
  When \a(), b() Then Say 'Surprise'
  Otherwise           Say 'ok: \\a() is false (Select)'
  End
Return

method a private static binary returns boolean
  state = Boolean.TRUE.booleanValue()
  Say '--a returns' state
  Return state

method b private static binary returns boolean
  state = Boolean.TRUE.booleanValue()
  Say '--b returns' state
  Return state


def inCarpet(x; y):
  x as $x | y as $y |
  if $x == -1 or $y == -1 then "\n"
  elif $x == 0 or $y == 0 then "*"
  elif ($x % 3) == 1 and ($y % 3) == 1 then " "
  else inCarpet($x/3 | floor; $y/3 | floor)
  end;

def ipow(n):
  . as $in | reduce range(0;n) as $i (1; . * $in);

def carpet(n):
  (3|ipow(n)) as $power
  | [ inCarpet( range(0; $power) ; range(0; $power), -1 )]
  | join("") ;

carpet(3)


function sierpinski(n::Integer, token::AbstractString="*")
    x = fill(token, 1, 1)
    for _ in 1:n
        t = fill(" ", size(x))
        x = [x x x; x t x; x x x]
    end
    return x
end

function printsierpinski(m::Matrix)
    for r in 1:size(m, 1)
        println(join(m[r, :]))
    end
end

sierpinski(2, "#") |> printsierpinski


// version 1.1.2

fun inCarpet(x: Int, y: Int): Boolean {
    var xx = x
    var yy = y
    while (xx != 0 && yy != 0) {
        if (xx % 3 == 1 && yy % 3 == 1) return false
        xx /= 3
        yy /= 3
    }
    return true
}

fun carpet(n: Int) {
    val power = Math.pow(3.0, n.toDouble()).toInt()
    for(i in 0 until power) {
        for(j in 0 until power) print(if (inCarpet(i, j)) "*" else " ")
        println()
    }
}

fun main(args: Array<String>) = carpet(3)


proc a(x): bool =
  echo "a called"
  result = x

proc b(x): bool =
  echo "b called"
  result = x

let x = a(false) and b(true) # echoes "a called"
let y = a(true) or b(true)   # echoes "a called"


class ShortCircuit {
  function : a(a : Bool) ~ Bool {
    "a"->PrintLine();
    return a;
  }

  function : b(b : Bool) ~ Bool {
    "b"->PrintLine();
    return b;
  }

  function : Main(args : String[]) ~ Nil {
    result := a(false) & b(false);
    "F and F = {$result}"->PrintLine();
    result := a(false) | b(false);
    "F or F = {$result}"->PrintLine();

    result := a(false) & b(true);
    "F and T = {$result}"->PrintLine();
    result := a(false) | b(true);
    "F or T = {$result}"->PrintLine();

    result := a(true) & b(false);
    "T and F = {$result}"->PrintLine();
    result := a(true) | b(false);
    "T or F = {$result}"->PrintLine();

    result := a(true) & b(true);
    "T and T = {$result}"->PrintLine();
    result := a(true) | b(true);
    "T or T = {$result}"->PrintLine();
  }
}


local function carpet(n, f)
  print("n = " .. n)
  local function S(x, y)
    if x==0 or y==0 then return true
    elseif x%3==1 and y%3==1 then return false end
    return S(x//3, y//3)
  end
  for y = 0, 3^n-1 do
    for x = 0, 3^n-1 do
      io.write(f(S(x, y)))
    end
    print()
  end
  print()
end

for n = 0, 4 do
  carpet(n, function(b) return b and "■ " or "  " end)
end


NoMainWin
WindowWidth  = 508
WindowHeight = 575
Open "Sierpinski Carpets" For Graphics_nsb_nf As #g
#g "Down; TrapClose [halt]"

'labels
#g "Place  90  15;\Order 0"
#g "Place 340  15;\Order 1"
#g "Place  90 286;\Order 2"
#g "Place 340 286;\Order 3"
'carpets
Call carpet   5,  20, 243, 0
Call carpet 253,  20, 243, 1
Call carpet   5, 293, 243, 2
Call carpet 253, 293, 243, 3
#g "Flush"
Wait

[halt]
Close #g
End

Sub carpet x, y, size, order
    #g "Color 0 0 128; BackColor 0 0 128"
    #g "Place ";x;" ";y
    #g "BoxFilled ";x+size-1;" ";y+size-1
    #g "Color white; BackColor white"
    side = Int(size/3)
    newX = x+side
    newY = y+side
    #g "Place ";newX;" ";newY
    #g "BoxFilled ";newX+side-1;" ";newY+side-1
    order = order - 1
    If order > -1 Then
        Call carpet newX-side, newY-side+1, side, order
        Call carpet newX,      newY-side+1, side, order
        Call carpet newX+side, newY-side+1, side, order
        Call carpet newX+side, newY,        side, order
        Call carpet newX+side, newY+side,   side, order
        Call carpet newX,      newY+side,   side, order
        Call carpet newX-side, newY+side,   side, order
        Call carpet newX-side, newY,        side, order
    End If
End Sub


let a r = print_endline " > function a called"; r
let b r = print_endline " > function b called"; r

let test_and b1 b2 =
  Printf.printf "# testing (%b && %b)\n" b1 b2;
  ignore (a b1 && b b2)

let test_or b1 b2 =
  Printf.printf "# testing (%b || %b)\n" b1 b2;
  ignore (a b1 || b b2)

let test_this test =
  test true true;
  test true false;
  test false true;
  test false false;
;;

let () =
  print_endline "==== Testing and ====";
  test_this test_and;
  print_endline "==== Testing or ====";
  test_this test_or;
;;


(define (a x)
   (print "   (a) => " x)
   x)

(define (b x)
   (print "   (b) => " x)
   x)

; and
(print " -- and -- ")
(for-each (lambda (x y)
      (print "let's evaluate '(a as " x ") and (b as " y ")':")
      (let ((out (and (a x) (b y))))
         (print "   result is " out)))
   '(#t #t #f #f)
   '(#t #f #t #f))

; or
(print " -- or -- ")
(for-each (lambda (x y)
      (print "let's evaluate '(a as " x ") or (b as " y ")':")
      (let ((out (or (a x) (b y))))
         (print "   result is " out)))
   '(#t #t #f #f)
   '(#t #f #t #f))


n = 3;
c = string('#');
for k = 1 : n
  c = [c + c + c, c + c.replace('#', ' ') + c, c + c + c];
end
disp(c.join(char(10)))


10 REM Sierpinski carpet
20 CLS
30 LET RDR=3
40 LET S=3^RDR
50 FOR I=0 TO S-1
60 FOR J=0 TO S-1
70 LET X=J
80 LET Y=I
90 GOSUB 300
100 IF C THEN SET(J,I)
110 NEXT J
120 NEXT I
130 REM ** Set up machine code INKEY$ command
140 IF PEEK(1)<>0 THEN RESTORE 410
150 DOKE 4100,3328:FOR A=3328 TO 3342 STEP 2
160 READ B:DOKE A,B:NEXT A
170 SCREEN 1,15
180 PRINT "Hit any key to exit.";
190 A=USR(0):IF A<0 THEN 190
200 CLS
210 END

290 REM ** Is (X,Y) in the carpet?
295 REM    Returns C=0 (no) or C=1 (yes).
300 LET C=0
310 XD3=INT(X/3):YD3=INT(Y/3)
320 IF X-XD3*3=1 AND Y-YD3*3=1 THEN RETURN
330 LET X=XD3
340 LET Y=YD3
350 IF X>0 OR Y>0 THEN GOTO 310
360 LET C=1
370 RETURN
395 REM ** Data for machine code INKEY$
400 DATA 25055,1080,-53,536,-20665,3370,-5664,0
410 DATA 27085,14336,-13564,6399,18178,10927
420 DATA -8179,233


Parse Version v
Say 'Version='v
If a() | b() Then Say 'a and b are true'
If \a() | b() Then Say  'Surprise'
              Else Say 'ok'
If a(), b() Then Say 'a is true'
If \a(), b() Then Say  'Surprise'
             Else Say 'ok: \a() is false'
Select
  When \a(), b() Then Say 'Surprise'
  Otherwise           Say 'ok: \a() is false (Select)'
  End
Exit
a: Say 'a returns .true'; Return .true
b: Say 'b returns 1'; Return 1


declare
  fun {A Answer}
     AnswerS = {Value.toVirtualString Answer 1 1}
  in
     {System.showInfo "  % Called function {A "#AnswerS#"} -> "#AnswerS}
     Answer
  end

  fun {B Answer}
     AnswerS = {Value.toVirtualString Answer 1 1}
  in
     {System.showInfo "  % Called function {B "#AnswerS#"} -> "#AnswerS}
     Answer
  end
in
  for I in [false true] do
     for J in [false true] do
        X Y
     in
        {System.showInfo "\nCalculating: X = {A I} andthen {B J}"}
        X = {A I} andthen {B J}
        {System.showInfo "Calculating: Y = {A I} orelse {B J}"}
        Y = {A I} orelse {B J}
     end
  end


/* NetRexx */
options replace format comments java crossref symbols nobinary

numeric digits 1000
runSample(arg)
return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) public static
  DARK_SHADE = '\u2593'
  parse arg ordr filr .
  if ordr = '' | ordr = '.' then ordr = 3
  if filr = '' | filr = '.' then filler = DARK_SHADE
  else                           filler = filr
  drawSierpinskiCarpet(ordr, filler)
  return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method drawSierpinskiCarpet(ordr, filler = Rexx '@') public static binary
  x = long
  y = long
  powr = 3 ** ordr
  loop x = 0 to powr - 1
    loop y = 0 to powr - 1
      if isSierpinskiCarpetCellFilled(x, y) then cell = filler
      else                                       cell = ' '
      say cell'\-'
      end y
      say
    end x
  return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method isSierpinskiCarpetCellFilled(x = long, y = long) public static binary returns boolean
  isTrue  = boolean (1 == 1)
  isFalse = \isTrue
  isFilled = isTrue
  loop label edge while x \= 0 & y \= 0
    if x // 3 = 1 & y // 3 = 1 then do
      isFilled = isFalse
      leave edge
      end
    x = x % 3
    y = y % 3
    end edge
  return isFilled


import math

proc inCarpet(x, y: int): bool =
  var x = x
  var y = y
  while true:
    if x == 0 or y == 0:
      return true
    if x mod 3 == 1 and y mod 3 == 1:
      return false
    x = x div 3
    y = y div 3

proc carpet(n: int) =
  for i in 0 ..< 3^n:
    for j in 0 ..< 3^n:
      stdout.write if inCarpet(i, j): "* " else: "  "
    echo()

carpet(3)


program shortcircuit(output);

function a(value: boolean): boolean;
 begin
  writeln('a(', value, ')');
  a := value
 end;

function b(value:boolean): boolean;
 begin
  writeln('b(', value, ')');
  b := value
 end;

procedure scandor(value1, value2: boolean);
 var
  result: boolean;
 begin
  {and}
  if a(value1)
   then
    result := b(value2)
   else
    result := false;
  writeln(value1, ' and ', value2, ' = ', result);

  {or}
  if a(value1)
   then
    result := true
   else
    result := b(value2)
  writeln(value1, ' or ', value2, ' = ', result);
 end;

begin
 scandor(false, false);
 scandor(false, true);
 scandor(true, false);
 scandor(true, true);
end.


class SierpinskiCarpet {
  function : Main(args : String[]) ~ Nil {
    Carpet(3);
  }

  function : InCarpet(x : Int, y : Int) ~ Bool {
    while(x<>0 & y<>0) {
      if(x % 3 = 1 & y % 3 = 1) {
        return false;
      };

      x /= 3;
      y /= 3;
    };

    return true;
  }

  function : Carpet(n : Int) ~ Nil {
    power := 3.0->Power(n->As(Float));
    for(i := 0; i < power; i+=1;) {
      for(j := 0; j < power; j+=1;) {
        c := InCarpet(i, j) ? '*' : ' ';
        c->Print();
      };
      IO.Console->PrintLine();
    };
  }
}


let rec in_carpet x y =
  if x = 0 || y = 0 then true
  else if x mod 3 = 1 && y mod 3 = 1 then false
  else in_carpet (x / 3) (y / 3)

(* I define my own operator for integer exponentiation *)
let rec (^:) a b =
  if b = 0 then 1
  else if b mod 2 = 0 then let x = a ^: (b / 2) in x * x
  else a * (a ^: (b - 1))

let carpet n =
  for i = 0 to (3 ^: n) - 1 do
    for j = 0 to (3 ^: n) - 1 do
      print_char (if in_carpet i j then '*' else ' ')
    done;
    print_newline ()
  done


sub a { print 'A'; return $_[0] }
sub b { print 'B'; return $_[0] }

# Test-driver
sub test {
    for my $op ('&&','||') {
        for (qw(1,1 1,0 0,1 0,0)) {
           my ($x,$y) = /(.),(.)/;
           print my $str = "a($x) $op b($y)", ': ';
           eval $str; print "\n"; } }
}

# Test and display
test();


with javascript_semantics
function a(integer i)
    printf(1,"a ")
    return i
end function

function b(integer i)
    printf(1,"b ")
    return i
end function

for z=0 to 1 do
    for i=0 to 1 do
        for j=0 to 1 do
            if z then
                printf(1,"a(%d) and b(%d) ",{i,j})
                printf(1," => %d\n",a(i) and b(j))
            else
                printf(1,"a(%d) or b(%d) ",{i,j})
                printf(1," => %d\n",a(i) or b(j))
            end if
        end for
    end for
end for


: carpet(n)
| dim i j k |
   3 n pow ->dim

   0 dim 1 - for: i [
      0 dim 1 - for: j [
          dim 3 / ->k
          while(k) [
             i k 3 * mod k / 1 == j k 3 * mod k / 1 == and ifTrue: [ break ]
             k 3 / ->k
             ]
          k ifTrue: [ " " ] else: [ "#" ] print
          ]
      printcr
      ] ;


#include <order/interpreter.h>

#define ORDER_PP_DEF_8in_carpet ORDER_PP_FN( \
8fn(8X, 8Y, \
    8if(8or(8is_0(8X), 8is_0(8Y)), \
        8true, \
        8let((8Q, 8quotient(8X, 3)) \
             (8R, 8remainder(8X, 3)) \
             (8S, 8quotient(8Y, 3)) \
             (8T, 8remainder(8Y, 3)), \
             8and(8not(8and(8equal(8R, 1), 8equal(8T, 1))), \
                  8in_carpet(8Q, 8S))))) )

#define ORDER_PP_DEF_8carpet ORDER_PP_FN( \
8fn(8N, \
    8lets((8R, 8seq_iota(0, 8pow(3, 8N))) \
          (8G, 8seq_map(8fn(8Y, 8seq_map(8fn(8X, 8pair(8X, 8Y)), \
                                         8R)), \
                        8R)), \
           8seq_map(8fn(8S, 8seq_map(8fn(8P, 8apply(8in_carpet, 8P)), \
                                     8S)), \
                    8G))) )

#define ORDER_PP_DEF_8carpet_to_string ORDER_PP_FN( \
8fn(8C, \
    8seq_fold( \
      8fn(8R, 8S, \
          8adjoin(8R, \
                  8seq_fold(8fn(8P, 8B, 8adjoin(8P, 8if(8B, 8("#"), 8(" ")))), \
                            8nil, 8S), \
                  8("\n"))), \
      8nil, 8C)) )

#include <stdio.h>

int main(void) {
	printf(ORDER_PP( 8carpet_to_string(8carpet(3)) ));
	return 0;
}


declare
  %% A carpet is a list of lines.
  fun {NextCarpet Carpet}
     {Flatten
      [{Map Carpet XXX}
       {Map Carpet X_X}
       {Map Carpet XXX}
      ]}
  end

  fun {XXX X} X#X#X end
  fun {X_X X} X#{Spaces {VirtualString.length X}}#X end
  fun {Spaces N} if N == 0 then nil else & |{Spaces N-1} end end

  fun lazy {Iterate F X}
     X|{Iterate F {F X}}
  end

  SierpinskiCarpets = {Iterate NextCarpet ["#"]}
in
  %% print all lines of the Sierpinski carpet of order 3
  {ForAll {Nth SierpinskiCarpets 4} System.showInfo}


(de a (F)
   (msg 'a)
   F )

(de b (F)
   (msg 'b)
   F )

(mapc
   '((I J)
      (for Op '(and or)
         (println I Op J '-> (Op (a I) (b J))) ) )
   '(NIL NIL T T)
   '(NIL T NIL T) )


int(0..1) a(int(0..1) i)
{
    write(" a\n");
    return i;
}

int(0..1) b(int(0..1) i)
{
    write(" b\n");
    return i;
}

foreach(({ ({ false, false }),  ({ false, true }), ({ true, true }), ({ true, false }) });; array(int) args)
{
    write(" %d && %d\n", @args);
    a(args[0]) && b(args[1]);

    write(" %d || %d\n", @args);
    a(args[0]) || b(args[1]);
}


short_circuit_evaluation:
   procedure options (main);
   declare (true initial ('1'b), false initial ('0'b) ) bit (1);
   declare (i, j, x, y) bit (1);

a: procedure (bv) returns (bit(1));
   declare bv bit(1);
   put ('Procedure ' || procedurename() || ' called.');
   return (bv);
end a;
b: procedure (bv) returns (bit(1));
   declare bv bit(1);
   put ('Procedure ' || procedurename() || ' called.');
   return (bv);
end b;

   do i = true, false;
      do j = true, false;
         put skip(2) list ('Evaluating x with <a> with ' || i || ' and <b> with ' || j);
         put skip;
         if a(i) then
            x = b(j);
         else
             x = false;
         put skip data (x);
         put skip(2) list ('Evaluating y with <a> with ' || i || ' and <b> with ' || j);
         put skip;
         if a(i) then
            y = true;
         else
            y = b(j);
         put skip data (y);
      end;
   end;
end short_circuit_evaluation;


\\ Improved simple plotting using matrix mat (color and scaling added).
\\ Matrix should be filled with 0/1. 7/6/16 aev
iPlotmat(mat,clr)={
  my(xz=#mat[1,],yz=#mat[,1],vx=List(),vy=vx,xmin,xmax,ymin,ymax,c=0.625);
  for(i=1,yz, for(j=1,xz, if(mat[i,j]==0, next, listput(vx,i); listput(vy,j))));
  xmin=listmin(vx); xmax=listmax(vx); ymin=listmin(vy); ymax=listmax(vy);
  plotinit(0); plotcolor(0,clr);
  plotscale(0, xmin,xmax,ymin,ymax);
  plotpoints(0, Vec(vx)*c,Vec(vy));
  plotdraw([0,xmin,ymin]);
  print(" *** matrix: ",xz,"x",yz,", ",#vy," DOTS");
}
\\ iPlotV2(): Improved plotting from a file written by the wrtmat(). (color added)
\\ Saving possibly huge generation time if re-plotting needed.
iPlotV2(fn, clr)={
  my(F,nf,vx=List(),vy=vx,Vr,xmin,xmax,ymin,ymax,c=0.625);
  F=readstr(fn); nf=#F;
  print(" *** Plotting from: ", fn, " - ", nf, " DOTS");
  for(i=1,nf, Vr=stok(F[i]," "); listput(vx,eval(Vr[1])); listput(vy,eval(Vr[2])));
  xmin=listmin(vx); xmax=listmax(vx); ymin=listmin(vy); ymax=listmax(vy);
  plotinit(0); plotcolor(0,clr);
  plotscale(0, xmin,xmax,ymin,ymax);
  plotpoints(0, Vec(vx)*c,Vec(vy));
  plotdraw([0,xmin,ymin]);
}
\\ Are x,y inside Sierpinski carpet? (1-yes, 0-no) 6/10/16 aev
inSC(x,y)={
  while(1, if(!x||!y,return(1));
    if(x%3==1&&y%3==1, return(0));
    x\=3; y\=3;);\\wend
}


#  Simulated fast function
function a ( [boolean]$J ) { return $J }

#  Simulated slow function
function b ( [boolean]$J ) { Sleep -Seconds 2; return $J }

#  These all short-circuit and do not evaluate the right hand function
( a $True  ) -or  ( b $False )
( a $True  ) -or  ( b $True  )
( a $False ) -and ( b $False )
( a $False ) -and ( b $True  )

#  Measure of execution time
Measure-Command {
( a $True  ) -or  ( b $False )
( a $True  ) -or  ( b $True  )
( a $False ) -and ( b $False )
( a $False ) -and ( b $True  )
} | Select TotalMilliseconds

#  These all appropriately do evaluate the right hand function
( a $False ) -or  ( b $False )
( a $False ) -or  ( b $True  )
( a $True  ) -and ( b $False )
( a $True  ) -and ( b $True  )

#  Measure of execution time
Measure-Command {
( a $False ) -or  ( b $False )
( a $False ) -or  ( b $True  )
( a $True  ) -and ( b $False )
( a $True  ) -and ( b $True  )
} | Select TotalMilliseconds


short_circuit :-
	(   a_or_b(true, true) -> writeln('==> true'); writeln('==> false')) , nl,
	(   a_or_b(true, false)-> writeln('==>  true'); writeln('==> false')) , nl,
	(   a_or_b(false, true)-> writeln('==> true'); writeln('==> false')) , nl,
	(   a_or_b(false, false)-> writeln('==> true'); writeln('==> false')) , nl,
	(   a_and_b(true, true)-> writeln('==> true'); writeln('==> false')) , nl,
	(   a_and_b(true, false)-> writeln('==>  true'); writeln('==> false')) , nl,
	(   a_and_b(false, true)-> writeln('==>  true'); writeln('==> false')) , nl,
	(   a_and_b(false, false)-> writeln('==>  true'); writeln('==> false')) .

a_and_b(X, Y) :-
	format('a(~w) and b(~w)~n', [X, Y]),
	(   a(X), b(Y)).

a_or_b(X, Y) :-
	format('a(~w) or b(~w)~n', [X, Y]),
	(   a(X); b(Y)).

a(X) :-
	format('a(~w)~n', [X]),
	X.

b(X) :-
	format('b(~w)~n', [X]),
	X.


program SierpinskiCarpet;

uses
  Math;

function In_carpet(a, b: longint): boolean;
var
  x, y: longint;
begin
  x := a;
  y := b;
  while true do
  begin
    if (x = 0) or (y = 0) then
    begin
      In_carpet := true;
      break;
    end
    else if ((x mod 3) = 1) and ((y mod 3) = 1) then
    begin
      In_carpet := false;
      break;
    end;
    x := x div 3;
    y := y div 3;
  end;
end;

procedure Carpet(n: integer);
var
  i, j, limit: longint;
begin
{$IFDEF FPC}
  limit := 3 *  * n - 1;
{$ELSE}
  limit := Trunc(IntPower(3, n) - 1);
{$ENDIF}

  for i := 0 to limit do
  begin
    for j := 0 to limit do
      if In_carpet(i, j) then
        write('*')
      else
        write(' ');
    writeln;
  end;
end;

begin
  Carpet(3);
  {$IFNDEF UNIX}      readln; {$ENDIF}
end.


Procedure a(arg)
  PrintN("  # Called function a("+Str(arg)+")")
  ProcedureReturn arg
EndProcedure

Procedure b(arg)
  PrintN("  # Called function b("+Str(arg)+")")
  ProcedureReturn arg
EndProcedure

OpenConsole()
For a=#False To #True
  For b=#False To #True
    PrintN(#CRLF$+"Calculating: x = a("+Str(a)+") And b("+Str(b)+")")
    x= a(a) And b(b)
    PrintN("Calculating: x = a("+Str(a)+") Or b("+Str(b)+")")
    y= a(a) Or b(b)
  Next
Next
Input()


>>> def a(answer):
	print("  # Called function a(%r) -> %r" % (answer, answer))
	return answer

>>> def b(answer):
	print("  # Called function b(%r) -> %r" % (answer, answer))
	return answer

>>> for i in (False, True):
	for j in (False, True):
		print ("\nCalculating: x = a(i) and b(j)")
		x = a(i) and b(j)
		print ("Calculating: y = a(i) or  b(j)")
		y = a(i) or  b(j)

Calculating: x = a(i) and b(j)
  # Called function a(False) -> False
Calculating: y = a(i) or  b(j)
  # Called function a(False) -> False
  # Called function b(False) -> False

Calculating: x = a(i) and b(j)
  # Called function a(False) -> False
Calculating: y = a(i) or  b(j)
  # Called function a(False) -> False
  # Called function b(True) -> True

Calculating: x = a(i) and b(j)
  # Called function a(True) -> True
  # Called function b(False) -> False
Calculating: y = a(i) or  b(j)
  # Called function a(True) -> True

Calculating: x = a(i) and b(j)
  # Called function a(True) -> True
  # Called function b(True) -> True
Calculating: y = a(i) or  b(j)
  # Called function a(True) -> True


constant order = 4

function InCarpet(atom x, atom y)
    while x!=0 and y!=0 do
        if floor(mod(x,3))=1 and floor(mod(y,3))=1 then
            return ' '
        end if
        x /= 3
        y /= 3
    end while
    return '#'
end function

for i=0 to power(3,order)-1 do
    for j=0 to power(3,order)-1 do
        puts(1,InCarpet(i,j))
    end for
    puts(1,'\n')
end for


a <- function(x) {cat("a called\n"); x}
b <- function(x) {cat("b called\n"); x}

tests <- expand.grid(op=list(quote(`||`), quote(`&&`)), x=c(1,0), y=c(1,0))

invisible(apply(tests, 1, function(row) {
  call <- substitute(op(a(x),b(y)), row)
  cat(deparse(call), "->", eval(call), "\n\n")
}))


#lang racket
(define (a x)
  (display (~a "a:" x " "))
  x)

(define (b x)
  (display (~a "b:" x " "))
  x)

(for* ([x '(#t #f)]
       [y '(#t #f)])
  (displayln `(and (a ,x) (b ,y)))
  (and (a x) (b y))
  (newline)

  (displayln `(or (a ,x) (b ,y)))
  (or (a x) (b y))
  (newline))


use MONKEY-SEE-NO-EVAL;

sub a ($p) { print 'a'; $p }
sub b ($p) { print 'b'; $p }

for 1, 0 X 1, 0 -> ($p, $q) {
    for '&&', '||' -> $op {
        my $s = "a($p) $op b($q)";
        print "$s: ";
        EVAL $s;
        print "\n";
    }
}


<?php

function isSierpinskiCarpetPixelFilled($x, $y) {
    while (($x > 0) or ($y > 0)) {
        if (($x % 3 == 1) and ($y % 3 == 1)) {
            return false;
        }
        $x /= 3;
        $y /= 3;
    }
    return true;
}

function sierpinskiCarpet($order) {
    $size = pow(3, $order);
    for ($y = 0 ; $y < $size ; $y++) {
        for ($x = 0 ; $x < $size ; $x++) {
            echo isSierpinskiCarpetPixelFilled($x, $y) ? '#' : ' ';
        }
        echo PHP_EOL;
    }
}

for ($order = 0 ; $order <= 3 ; $order++) {
    echo 'N=', $order, PHP_EOL;
    sierpinskiCarpet($order);
    echo PHP_EOL;
}


in_carpet(X, Y) =>
    while (X != 0, Y != 0)
        if (X mod 3 == 1, Y mod 3 == 1) then
            false
        end,
        X := X div 3,
        Y := Y div 3
    end.

in_carpet(_, _) =>
    true.

main(Args) =>
    N = to_int(Args[1]),
    Power1 = 3 ** N - 1,
    foreach (I in 0..Power1)
        foreach (J in 0..Power1)
            printf("%w", cond(in_carpet(I, J), "*", " "))
        end,
        nl
    end.


/*REXX programs demonstrates short─circuit evaluation testing  (in an   IF   statement).*/
parse arg LO HI .                                /*obtain optional arguments from the CL*/
if LO=='' | LO==","  then LO= -2                 /*Not specified?  Then use the default.*/
if HI=='' | HI==","  then HI=  2                 /* "      "         "   "   "     "    */

         do j=LO  to HI                          /*process from the  low  to  the  high.*/
         x=a(j)  &  b(j)                         /*compute  function A  and  function B */
         y=a(j)  |  b(j)                         /*   "         "    "   or      "    " */
         if \y  then y=b(j)                      /*   "         "    B   (for negation).*/
         say  copies('═', 30)        '  x=' || x            '  y='y                '  j='j
         say
         end   /*j*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
a: say '      A  entered with:'  arg(1);    return abs( arg(1) // 2)   /*1=odd, 0=even  */
b: say '      B  entered with:'  arg(1);    return arg(1) < 0          /*1=neg, 0=if not*/


# Project : Short-circuit evaluation

for k = 1 to 2
      word = ["AND","OR"]
      see "========= " + word[k] + " ==============" + nl
      for i = 0 to 1
           for j = 0 to 1
                see "a(" + i + ") " + word[k] +" b(" + j + ")" + nl
                res =a(i)
                if word[k] = "AND" and res != 0
                   res = b(j)
                ok
                if word[k] = "OR"  and res = 0
                   res = b(j)
                ok
           next
      next
next

func a(t)
        see char(9) + "calls func a" + nl
        a = t
        return a

func b(t)
        see char(9) + "calls func b" + nl
        b = t
        return b


def a( bool )
  puts "a( #{bool} ) called"
  bool
end

def b( bool )
  puts "b( #{bool} ) called"
  bool
end

 [true, false].each do |a_val|
   [true, false].each do |b_val|
     puts "a( #{a_val} ) and b( #{b_val} ) is #{a( a_val ) and b( b_val )}."
     puts
     puts "a( #{a_val} ) or b( #{b_val} ) is #{a( a_val)  or b( b_val )}."
     puts
   end
 end


(de carpet (N)
   (let Carpet '("#")
      (do N
         (setq Carpet
            (conc
               (mapcar '((S) (pack S S S)) Carpet)
               (mapcar
                  '((S) (pack S (replace (chop S) "#" " ") S))
                  Carpet )
               (mapcar '((S) (pack S S S)) Carpet) ) ) ) ) )

(mapc prinl (carpet 3))


/* Sierpinski carpet */

Sierpinski_carpet: procedure options (main); /* 28 January 2013 */

  call carpet(3);

In_carpet: procedure (a, b) returns (bit(1));
  declare (a, b) fixed binary nonassignable;
  declare (x, y) fixed binary;
  declare (true value ('1'b), false value ('0'b)) bit (1);

   x = a ; y = b;
   do forever;
      if x = 0 | y = 0 then
         return (true);
      else if mod(x, 3) = 1 & mod(y, 3) = 1 then
         return (false);
      x = x / 3;
      y = y / 3;
   end;
end in_carpet;

Carpet: procedure (n);
  declare n fixed binary nonassignable;
  declare (i, j) fixed binary;

  do i = 0 to 3**n - 1;
     do j = 0 to 3**n - 1;
        if In_carpet(i, j) then
           put edit ('#') (a);
        else
           put edit (' ') (a);
     end;
     put skip;
  end;
end Carpet;
end Sierpinski_carpet;


%!PS-Adobe-3.0
%%BoundingBox 0 0 300 300

/r { moveto 0 -1 1 0 0 1 3 { rlineto } repeat closepath fill } def
/serp { gsave
        3 1 roll translate
        1 3 div dup scale
        1 1 r
        dup 1 sub dup 0 eq not {
                0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 17 -1 roll 8 { serp } repeat
        } if pop
        grestore
} def

300 300 scale 0 0 r 1 setgray

0 0 5 serp

pop showpage
%%EOF


for k = 1 to 2
ao$ = word$("AND,OR",k,",")
print "========= ";ao$;" =============="
for i = 0 to 1
    for j = 0 to 1
        print "a("; i; ") ";ao$;" b("; j; ")"
        res =a(i)    'call always
'print res;"<===="
if ao$ = "AND" and res <> 0 then res = b(j)
if ao$ = "OR"  and res =  0 then res = b(j)
    next
next
next k
end

function a( t)
    print chr$(9);"calls func a"
    a = t
end function

function b( t)
    print chr$(9);"calls func b"
    b = t
end function


fn a(foo: bool) -> bool {
    println!("a");
    foo
}

fn b(foo: bool) -> bool {
    println!("b");
    foo
}

fn main() {
    for i in vec![true, false] {
        for j in vec![true, false] {
            println!("{} and {} == {}", i, j, a(i) && b(j));
            println!("{} or {} == {}", i, j, a(i) || b(j));
            println!();
        }
    }
}


class MAIN is
  a(v:BOOL):BOOL is
    #OUT + "executing a\n";
    return v;
  end;
  b(v:BOOL):BOOL is
    #OUT + "executing b\n";
    return v;
  end;

  main is
    x:BOOL;

    x := a(false) and b(true);
    #OUT + "F and T = " + x + "\n\n";

    x := a(true) or b(true);
    #OUT + "T or T = " + x + "\n\n";

    x := a(true) and b(false);
    #OUT + "T and T = " + x + "\n\n";

    x := a(false) or b(true);
    #OUT + "F or T = " + x + "\n\n";
  end;
end;


object ShortCircuit {
   def a(b:Boolean)={print("Called A=%5b".format(b));b}
   def b(b:Boolean)={print(" -> B=%5b".format(b));b}

   def main(args: Array[String]): Unit = {
      val boolVals=List(false,true)
      for(aa<-boolVals; bb<-boolVals){
         print("\nTesting A=%5b AND B=%5b   -> ".format(aa, bb))
         a(aa) && b(bb)
      }
      for(aa<-boolVals; bb<-boolVals){
         print("\nTesting A=%5b  OR B=%5b   -> ".format(aa, bb))
         a(aa) || b(bb)
      }
      println
   }
}


function Draw-SierpinskiCarpet ( [int]$N )
    {
    $Carpet = @( '#' ) * [math]::Pow( 3, $N )
    ForEach ( $i in 1..$N )
        {
        $S = [math]::Pow( 3, $i - 1 )
        ForEach ( $Row in 0..($S-1) )
            {
            $Carpet[$Row+$S+$S] = $Carpet[$Row] * 3
            $Carpet[$Row+$S]    = $Carpet[$Row] + ( " " * $Carpet[$Row].Length ) + $Carpet[$Row]
            $Carpet[$Row]       = $Carpet[$Row] * 3
            }
        }
    $Carpet
    }

Draw-SierpinskiCarpet 3


float delta;

void setup() {
  size(729, 729);
  fill(0);
  background(255);
  noStroke();
  rect(width/3, height/3, width/3, width/3);
  rectangles(width/3, height/3, width/3);
}

void rectangles(int x, int y, int s) {
  if (s < 1) return;
  int xc = x-s;
  int yc = y-s;
  for (int row = 0; row < 3; row++) {
    for (int col = 0; col < 3; col++) {
      if (!(row == 1 && col == 1)) {
        int xx = xc+row*s;
        int yy = yc+col*s;
        delta = s/3;
        rect(xx+delta, yy+delta, delta, delta);
        rectangles(xx+s/3, yy+s/3, s/3);
      }
    }
  }
}


>(define (a x)
   (display "a\n")
   x)
>(define (b x)
   (display "b\n")
   x)
>(for-each (lambda (i)
   (for-each (lambda (j)
     (display i) (display " and ") (display j) (newline)
     (and (a i) (b j))
     (display i) (display " or ") (display j) (newline)
     (or (a i) (b j))
    ) '(#t #f))
  ) '(#t #f))
#t and #t
a
b
#t or #t
a
#t and #f
a
b
#t or #f
a
#f and #t
a
#f or #t
a
b
#f and #f
a
#f or #f
a
b


$ include "seed7_05.s7i";

const func boolean: a (in boolean: aBool) is func
  result
    var boolean: result is FALSE;
  begin
    writeln("a");
    result := aBool;
  end func;

const func boolean: b (in boolean: aBool) is func
  result
    var boolean: result is FALSE;
  begin
    writeln("b");
    result := aBool;
  end func;

const proc: test (in boolean: param1, in boolean: param2) is func
  begin
    writeln(param1 <& " and " <& param2 <& " = " <& a(param1) and b(param2));
    writeln(param1 <& " or " <& param2 <& " = " <& a(param1) or b(param2));
  end func;

const proc: main is func
  begin
    test(FALSE, FALSE);
    test(FALSE, TRUE);
    test(TRUE, FALSE);
    test(TRUE, TRUE);
  end func;


main:-
    write_sierpinski_carpet('sierpinski_carpet.svg', 486, 4).

write_sierpinski_carpet(File, Size, Order):-
    open(File, write, Stream),
    format(Stream,
           "<svg xmlns='http://www.w3.org/2000/svg' width='~d' height='~d'>\n",
           [Size, Size]),
    write(Stream, "<rect width='100%' height='100%' fill='white'/>\n"),
    Side is Size/3.0,
    sierpinski_carpet(Stream, 0, 0, Side, Order),
    write(Stream, "</svg>\n"),
    close(Stream).

sierpinski_carpet(Stream, X, Y, Side, 0):-
    !,
    X0 is X + Side,
    Y0 is Y + Side,
    write_square(Stream, X0, Y0, Side).
sierpinski_carpet(Stream, X, Y, Side, Order):-
    Order1 is Order - 1,
    Side1 is Side / 3.0,
    X0 is X + Side,
    Y0 is Y + Side,
    X1 is X0 + Side,
    Y1 is Y0 + Side,
    write_square(Stream, X0, Y0, Side),
    sierpinski_carpet(Stream, X, Y, Side1, Order1),
    sierpinski_carpet(Stream, X0, Y, Side1, Order1),
    sierpinski_carpet(Stream, X1, Y, Side1, Order1),
    sierpinski_carpet(Stream, X, Y0, Side1, Order1),
    sierpinski_carpet(Stream, X1, Y0, Side1, Order1),
    sierpinski_carpet(Stream, X, Y1, Side1, Order1),
    sierpinski_carpet(Stream, X0, Y1, Side1, Order1),
    sierpinski_carpet(Stream, X1, Y1, Side1, Order1).

write_square(Stream, X, Y, Side):-
    format(Stream,
           "<rect fill='black' x='~g' y='~g' width='~g' height='~g'/>\n",
           [X, Y, Side, Side]).


func a(bool) { print 'A'; return bool }
func b(bool) { print 'B'; return bool }

# Test-driver
func test() {
    for op in ['&&', '||'] {
        for x,y in [[1,1],[1,0],[0,1],[0,0]] {
            "a(%s) %s b(%s): ".printf(x, op, y)
            eval "a(Bool(x)) #{op} b(Bool(y))"
            print "\n"
        }
    }
}

# Test and display
test()


BEGIN

    BOOLEAN PROCEDURE A(BOOL); BOOLEAN BOOL;
    BEGIN OUTCHAR('A'); A := BOOL;
    END A;

    BOOLEAN PROCEDURE B(BOOL); BOOLEAN BOOL;
    BEGIN OUTCHAR('B'); B := BOOL;
    END B;

    PROCEDURE OUTBOOL(BOOL); BOOLEAN BOOL;
        OUTCHAR(IF BOOL THEN 'T' ELSE 'F');

    PROCEDURE TEST;
    BEGIN
        PROCEDURE ANDTEST;
        BEGIN
            BOOLEAN X, Y, Z;
            FOR X := TRUE, FALSE DO
                FOR Y := TRUE, FALSE DO
                BEGIN
                    OUTTEXT("A("); OUTBOOL(X);
                    OUTTEXT(") AND ");
                    OUTTEXT("B("); OUTBOOL(Y);
                    OUTTEXT("): ");
                    Z := A(X) AND THEN B(Y);
                    OUTIMAGE;
                END;
        END ANDTEST;

        PROCEDURE ORTEST;
        BEGIN
            BOOLEAN X, Y, Z;
            FOR X := TRUE, FALSE DO
                FOR Y := TRUE, FALSE DO
                BEGIN
                    OUTTEXT("A("); OUTBOOL(X);
                    OUTTEXT(") OR ");
                    OUTTEXT("B("); OUTBOOL(Y);
                    OUTTEXT("): ");
                    Z := A(X) OR ELSE B(Y);
                    OUTIMAGE;
                END;
        END ORTEST;

        ANDTEST;
        ORTEST;

    END TEST;

    TEST;
END.


Smalltalk at: #a put: nil.
Smalltalk at: #b put: nil.

a := [:x| 'executing a' displayNl. x].
b := [:x| 'executing b' displayNl. x].

('false and false = %1' %
  { (a value: false) and: [ b value: false ] })
    displayNl.

('true or false = %1' %
  { (a value: true) or: [ b value: false ] })
    displayNl.

('false or true = %1' %
  { (a value: false) or: [ b value: true ] })
    displayNl.

('true and false = %1' %
  { (a value: true) and: [ b value: false ] })
    displayNl.


Procedure in_carpet(x,y)
  While x>0 And y>0
    If x%3=1 And y%3=1
      ProcedureReturn #False
    EndIf
    y/3: x/3
  Wend
  ProcedureReturn #True
EndProcedure

Procedure carpet(n)
  Define i, j, l=Pow(3,n)-1
  For i=0 To l
    For j=0 To l
      If in_carpet(i,j)
        Print("#")
      Else
        Print(" ")
      EndIf
    Next
    PrintN("")
  Next
EndProcedure


def in_carpet(x, y):
    while True:
        if x == 0 or y == 0:
            return True
        elif x % 3 == 1 and y % 3 == 1:
            return False

        x /= 3
        y /= 3

def carpet(n):
    for i in xrange(3 ** n):
        for j in xrange(3 ** n):
            if in_carpet(i, j):
                print '*',
            else:
                print ' ',
        print


        define('a(val)') :(a_end)
a       out = 'A '
        eq(val,1) :s(return)f(freturn)
a_end

        define('b(val)') :(b_end)
b       out = 'B '
        eq(val,1) :s(return)f(freturn)
b_end

*       # Test and display
        &fullscan = 1
        output(.out,1,'-[-r1]') ;* Macro Spitbol
*       output(.out,1,'B','-')  ;* CSnobol
        define('nl()'):(nlx);nl output = :(return);nlx

        out = 'T and T: '; null ? *a(1) *b(1); nl()
        out = 'T and F: '; null ? *a(1) *b(0); nl()
        out = 'F and T: '; null ? *a(0) *b(1); nl()
        out = 'F and F: '; null ? *a(0) *b(0); nl()
        output =
        out = 'T or T: '; null ? *a(1) | *b(1); nl()
        out = 'T or F: '; null ? *a(1) | *b(0); nl()
        out = 'F or T: '; null ? *a(0) | *b(1); nl()
        out = 'F or F: '; null ? *a(0) | *b(0); nl()
end


fun a r = ( print " > function a called\n"; r )
fun b r = ( print " > function b called\n"; r )

fun test_and b1 b2 = (
  print ("# testing (" ^ Bool.toString b1 ^ " andalso " ^ Bool.toString b2 ^ ")\n");
  ignore (a b1 andalso b b2) )

fun test_or b1 b2 = (
  print ("# testing (" ^ Bool.toString b1 ^ " orelse " ^ Bool.toString b2 ^ ")\n");
  ignore (a b1 orelse b b2) )

fun test_this test = (
  test true true;
  test true false;
  test false true;
  test false false )
;

print "==== Testing and ====\n";
test_this test_and;
print "==== Testing or ====\n";
test_this test_or;


function a(x) {
	printf(" a")
	return(x)
}

function b(x) {
	printf(" b")
	return(x)
}

function call(i, j) {
	printf("and:")
	x = a(i)
	if (x) {
		x = b(j)
	}
	printf("\nor:")
	y = a(i)
	if (!y) {
		y = b(j)
	}
	printf("\n")
	return((x,y))
}


func a(v: Bool) -> Bool {
  print("a")
  return v
}

func b(v: Bool) -> Bool {
  print("b")
  return v
}

func test(i: Bool, j: Bool) {
  println("Testing a(\(i)) && b(\(j))")
  print("Trace:  ")
  println("\nResult: \(a(i) && b(j))")

  println("Testing a(\(i)) || b(\(j))")
  print("Trace:  ")
  println("\nResult: \(a(i) || b(j))")

  println()
}

test(false, false)
test(false, true)
test(true, false)
test(true, true)


_Title "Sierpinski Carpet"

Screen _NewImage(500, 545, 8)
Cls , 15: Color 1, 15

'labels
_PrintString (96, 8), "Order 0"
_PrintString (345, 8), "Order 1"
_PrintString (96, 280), "Order 3"
_PrintString (345, 280), "Order 4"

'carpets
Call carpet(5, 20, 243, 0)
Call carpet(253, 20, 243, 1)
Call carpet(5, 293, 243, 2)
Call carpet(253, 293, 243, 3)

Sleep
System

Sub carpet (x As Integer, y As Integer, size As Integer, order As Integer)
    Dim As Integer ix, iy, isize, iorder, side, newX, newY
    ix = x: iy = y: isize = size: iorder = order
    Line (ix, iy)-(ix + isize - 1, iy + isize - 1), 1, BF

    side = Int(isize / 3)
    newX = ix + side
    newY = iy + side
    Line (newX, newY)-(newX + side - 1, newY + side - 1), 15, BF
    iorder = iorder - 1
    If iorder >= 0 Then
        Call carpet(newX - side, newY - side + 1, side, iorder)
        Call carpet(newX, newY - side + 1, side, iorder)
        Call carpet(newX + side, newY - side + 1, side, iorder)
        Call carpet(newX + side, newY, side, iorder)
        Call carpet(newX + side, newY + side, side, iorder)
        Call carpet(newX, newY + side, side, iorder)
        Call carpet(newX - side, newY + side, side, iorder)
        Call carpet(newX - side, newY, side, iorder)
    End If
End Sub


  [ over 3 mod 1 = ]             is 1?       ( n1 n2 --> n1 n2 f )

  [ 3 / swap ]                   is 3/       ( n1 n2 --> n2/3 n1 )

  [ true unrot
    [ 2dup or while
      1? 1? and iff
        [ rot not unrot ] done
      3/ 3/ again ]
  2drop ]                        is incarpet (    n -->          )

  [ 1 swap times [ 3 * ]
    dup times
      [ i^ over times
          [ i^ over incarpet iff
              [ say "[]" ]
            else
              [ say "  " ] ]
          drop cr ]
    drop ]                       is carpet   (    n -->          )

4 carpet


## Are x,y inside Sierpinski carpet (and where)? (1-yes, 0-no)
inSC <- function(x, y) {
  while(TRUE) {
    if(!x||!y) {return(1)}
    if(x%%3==1&&y%%3==1) {return(0)}
    x=x%/%3; y=y%/%3;
  } return(0);
}
## Plotting Sierpinski carpet fractal. aev 4/1/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiC <- function(ord, fn="", ttl="", clr="navy") {
  m=640; abbr="SCR"; dftt="Sierpinski carpet fractal";
  n=3^ord-1; M <- matrix(c(0), ncol=n, nrow=n, byrow=TRUE);
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  for(i in 0:n) {
    for(j in 0:n) {if(inSC(i,j)) {M[i,j]=1}
  }}
  plotmat(M, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiC(5);


package require Tcl 8.5
proc tcl::mathfunc::a boolean {
    puts "a($boolean) called"
    return $boolean
}
proc tcl::mathfunc::b boolean {
    puts "b($boolean) called"
    return $boolean
}

foreach i {false true} {
    foreach j {false true} {
        set x [expr {a($i) && b($j)}]
        puts "x = a($i) && b($j) = $x"
        set y [expr {a($i) || b($j)}]
        puts "y = a($i) || b($j) = $y"
        puts ""; # Blank line for clarity
    }
}


@(define a (x out))
@  (output)
  a (@x) called
@  (end)
@  (bind out x)
@(end)
@(define b (x out))
@  (output)
  b (@x) called
@  (end)
@  (bind out x)
@(end)
@(define short_circuit_demo (i j))
@  (output)
a(@i) and b(@j):
@  (end)
@  (maybe)
@    (a i "1")
@    (b j "1")
@  (end)
@  (output)
a(@i) or b(@j):
@  (end)
@  (cases)
@    (a i "1")
@  (or)
@    (b j "1")
@  (or)
@    (accept)
@  (end)
@(end)
@(short_circuit_demo "0" "0")
@(short_circuit_demo "0" "1")
@(short_circuit_demo "1" "0")
@(short_circuit_demo "1" "1")


a() {
	echo "Called a $1"
	"$1"
}

b() {
	echo "Called b $1"
	"$1"
}

for i in false true; do
	for j in false true; do
		a $i && b $j && x=true || x=false
		echo "  $i && $j is $x"

		a $i || b $j && y=true || y=false
		echo "  $i || $j is $y"
	done
done


#lang racket
(define (carpet n)
  (if (zero? n)
    '("#")
    (let* ([prev   (carpet (sub1 n))]
           [spaces (regexp-replace* #rx"#" (car prev) " ")])
      (append (map (λ(x) (~a x x x)) prev)
              (map (λ(x) (~a x spaces x)) prev)
              (map (λ(x) (~a x x x)) prev)))))
(for-each displayln (carpet 3))


sub carpet
{
    (['#'], -> @c {
       [
        |@c.map({$_ x 3}),
        |@c.map({ $_ ~ $_.trans('#'=>' ') ~ $_}),
        |@c.map({$_ x 3})
       ]
    } ... *).map: { .join("\n") };
}

say carpet[3];

# Same as above, structured as an array bound to a sequence, with a separate sub for clarity.
sub weave ( @c ) {
   [
    |@c.map({ $_ x 3 }),
    |@c.map({ $_ ~ .trans( '#' => ' ' ) ~ $_ }),
    |@c.map({ $_ x 3 })
   ]
}

my @carpet = ( ['#'], &weave ... * ).map: { .join: "\n" };

say @carpet[3];

# Output of both versions matches task example.


Private Function a(i As Variant) As Boolean
    Debug.Print "a:  "; i = 1,
    a = i
End Function
Private Function b(j As Variant) As Boolean
    Debug.Print "b: "; j = 1;
    b = j
End Function
Public Sub short_circuit()
    Dim x As Boolean, y As Boolean
    'Dim p As Boolean, q As Boolean
    Debug.Print "=====AND=====" & vbCrLf
    For p = 0 To 1
        For q = 0 To 1
            If a(p) Then
                x = b(q)
            End If
            Debug.Print " = x"
        Next q
        Debug.Print
    Next p
    Debug.Print "======OR=====" & vbCrLf
    For p = 0 To 1
        For q = 0 To 1
            If Not a(p) Then
                x = b(q)
            End If
            Debug.Print " = x"
        Next q
        Debug.Print
    Next p
    Debug.Print
End Sub


Module Module1

    Function A(v As Boolean) As Boolean
        Console.WriteLine("a")
        Return v
    End Function

    Function B(v As Boolean) As Boolean
        Console.WriteLine("b")
        Return v
    End Function

    Sub Test(i As Boolean, j As Boolean)
        Console.WriteLine("{0} and {1} = {2} (eager evaluation)", i, j, A(i) And B(j))
        Console.WriteLine("{0} or {1} = {2} (eager evaluation)", i, j, A(i) Or B(j))
        Console.WriteLine("{0} and {1} = {2} (lazy evaluation)", i, j, A(i) AndAlso B(j))
        Console.WriteLine("{0} or {1} = {2} (lazy evaluation)", i, j, A(i) OrElse B(j))

        Console.WriteLine()
    End Sub

    Sub Main()
        Test(False, False)
        Test(False, True)
        Test(True, False)
        Test(True, True)
    End Sub

End Module


function incarpet(x,y)
set a = x
set b = y
while floor(a)>0 and floor(b)>0
if floor(a mod 3) = 1 and floor(b mod 3) = 1
set a = -1
set b = -1
else
set a = a / 3
set b = b / 3
end if
end while
if a < 0
set result = "_"
else
set result = "#"
end if
end function

program carpet(n)
set d = pow(3,n)
set y = 0
while y < d
set x = 0
set result = " "
while x < d
set result = result . incarpet(x,y)
set x = x  + 1
end while
echo result
set y = y + 1
end while
end program

run carpet(3)


/*REXX program draws any order Sierpinski carpet (order 20 would be ≈ 3.4Gx3.4G carpet).*/
parse arg N char .                               /*get the  order  of the carpet.       */
if N==''  |  N==","  then    N= 3                /*if none specified, then assume  3.   */
if char==''          then char= "*"              /*use the default of an asterisk  (*). */
if length(char)==2   then char= x2c(char)        /*it was specified in hexadecimal char.*/
if length(char)==3   then char= d2c(char)        /* "  "      "      " decimal character*/
width= linesize()                                /*the width of the terminal screen.    */
if N>18  then numeric digits 100                 /*just in case the user went  ka─razy. */
nnn= 3**N                                        /* [↓]  NNN  is the  cube of  N.       */

  do   j=0  for nnn;    z=                       /*Z:  will be the line to be displayed.*/
    do k=0  for nnn;   jj= j;   kk= k;   x= char
      do  while  jj\==0  &  kk\==0               /*one symbol for a  not (¬)  is a   \  */
      if jj//3==1  then if kk//3==1  then do     /*in REXX:    //  ≡  division remainder*/
                                          x= ' ' /*use a blank for this display line.   */
                                          leave  /*LEAVE   terminates this   DO  WHILE. */
                                          end
      jj= jj % 3;          kk= kk % 3            /*in REXX:     %  ≡  integer division. */
      end   /*while*/

    z= z || x                                    /*X      is either   black  or  white. */
    end     /*k*/                                /* [↑]    "    "       "     "  blank. */

  if length(z)<width  then say z                 /*display the line if it fits on screen*/
  call lineout 'Sierpinski.'N, z                 /*also, write the line to a (disk) file*/
  end       /*j*/                                /*stick a fork in it,  we're all done. */


*!* Visual FoxPro natively supports short circuit evaluation
CLEAR
CREATE CURSOR funceval(arg1 L, arg2 L, operation V(3), result L, calls V(10))
*!* Conjunction
INSERT INTO funceval (arg1, arg2, operation) VALUES (.F., .F., "AND")
REPLACE result WITH (a(arg1) AND b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.F., .T., "AND")
REPLACE result WITH (a(arg1) AND b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.T., .F., "AND")
REPLACE result WITH (a(arg1) AND b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.T., .T., "AND")
REPLACE result WITH (a(arg1) AND b(arg2))
*!* Disjunction
INSERT INTO funceval (arg1, arg2, operation) VALUES (.F., .F., "OR")
REPLACE result WITH (a(arg1) OR b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.F., .T., "OR")
REPLACE result WITH (a(arg1) OR b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.T., .F., "OR")
REPLACE result WITH (a(arg1) OR b(arg2))
INSERT INTO funceval (arg1, arg2, operation) VALUES (.T., .T., "OR")
REPLACE result WITH (a(arg1) OR b(arg2))
GO TOP

_VFP.DataToClip("funceval", 8, 3)

FUNCTION a(v As Boolean) As Boolean
REPLACE calls WITH "a()"
RETURN v
ENDFUNC

FUNCTION b(v As Boolean) As Boolean
REPLACE calls WITH calls + ", b()"
RETURN v
ENDFUNC


var a = Fn.new { |bool|
    System.print("  a called")
    return bool
}

var b = Fn.new { |bool|
    System.print("  b called")
    return bool
}

var bools = [ [true, true], [true, false], [false, true], [false, false] ]
for (bool in bools) {
    System.print("a = %(bool[0]), b = %(bool[1]), op = && :")
    a.call(bool[0]) && b.call(bool[1])
    System.print()
}

for (bool in bools) {
    System.print("a = %(bool[0]), b = %(bool[1]), op = || :")
    a.call(bool[0]) || b.call(bool[1])
    System.print()
}


fcn a(b){self.fcn.println(b); b}
fcn b(b){self.fcn.println(b); b}


load "guilib.ring"

new qapp
        {
        win1 = new qwidget() {
                   etwindowtitle("drawing using qpainter")
                   setgeometry(100,100,500,500)
               label1 = new qlabel(win1) {
                        setgeometry(10,10,400,400)
                        settext("")
               }
               new qpushbutton(win1) {
                   setgeometry(200,450,100,30)
                   settext("draw")
                   setclickevent("draw()")
               }
               show()
         }
         exec()
         }

func draw
     p1 = new qpicture()
          color = new qcolor() {
          setrgb(0,0,255,255)
     }
     pen = new qpen() {
           setcolor(color)
           setwidth(1)
     }
     new qpainter() {
         begin(p1)
         setpen(pen)

         order = 3
         side = pow(3,order)
         for y = 0 to side-1
             for x = 0 to side-1
                 if carpet(self,x,y)
                    drawpoint(x*16,y*16+15)
                    drawpoint(x*16+1,y*16+16)
                    drawpoint(x*16+2,y*16+17) ok
             next
         next

         endpaint()
        }
        label1 { setpicture(p1) show() }

        func carpet myObj,x,y
             myObj{while x!=0 and y!=0
                         if x % 3 = 1 if y % 3 = 1 return false ok ok
                         x = floor(x/3)
                         y = floor(y/3)
                   end
                   return true}


def sierpinski_carpet(n)
  carpet = ["#"]
  n.times do
    carpet = carpet.collect {|x| x + x + x} +
             carpet.collect {|x| x + x.tr("#"," ") + x} +
             carpet.collect {|x| x + x + x}
  end
  carpet
end

4.times{|i| puts "\nN=#{i}", sierpinski_carpet(i)}


fn main() {
    for i in 0..4 {
        println!("\nN={}", i);
        println!("{}", sierpinski_carpet(i));
    }
}

fn sierpinski_carpet(n: u32) -> String {
    let mut carpet = vec!["#".to_string()];
    for _ in 0..n {
        let mut top: Vec<_> = carpet.iter().map(|x| x.repeat(3)).collect();
        let middle: Vec<_> = carpet
            .iter()
            .map(|x| x.to_string() + &x.replace("#", " ") + x)
            .collect();
        let bottom = top.clone();

        top.extend(middle);
        top.extend(bottom);
        carpet = top;
    }
    carpet.join("\n")
}


def nextCarpet(carpet: List[String]): List[String] = (
  carpet.map(x => x + x + x) :::
  carpet.map(x => x + x.replace('#', ' ') + x) :::
  carpet.map(x => x + x + x))

def sierpinskiCarpets(n: Int) = (Iterator.iterate(List("#"))(nextCarpet) drop n next) foreach println


(define (carpet n)
  (define (in-carpet? x y)
    (cond ((or (zero? x) (zero? y))
              #t)
          ((and (= 1 (remainder x 3)) (= 1 (remainder y 3)))
              #f)
          (else
              (in-carpet? (quotient x 3) (quotient y 3)))))

  (do ((i 0 (+ i 1))) ((not (< i (expt 3 n))))
    (do ((j 0 (+ j 1))) ((not (< j (expt 3 n))))
      (display (if (in-carpet? i j)
                   #\*
                   #\space)))
    (newline)))


$ include "seed7_05.s7i";

const func boolean: inCarpet (in var integer: x, in var integer: y) is func
  result
    var boolean: result is TRUE;
  begin
    while result and x <> 0 and y <> 0 do
      if x rem 3 = 1 and y rem 3 = 1 then
        result := FALSE;
      else
        x := x div 3;
        y := y div 3;
      end if;
    end while;
  end func;

const proc: carpet (in integer: n) is func
  local
    var integer: i is 0;
    var integer: j is 0;
  begin
    for i range 0 to pred(3 ** n) do
      for j range 0 to pred(3 ** n) do
        if inCarpet(i, j) then
          write("#");
        else
          write(" ");
        end if;
      end for;
      writeln;
    end for;
  end func;

const proc: main is func
  begin
    carpet(3);
  end func;


 10 LET O=3
 20 LET S=3**O
 30 FOR I=0 TO S-1
 40 FOR J=0 TO S-1
 50 LET X=J
 60 LET Y=I
 70 GOSUB 120
 80 IF C THEN PLOT J,I
 90 NEXT J
100 NEXT I
110 GOTO 190
120 LET C=0
130 IF X-INT (X/3)*3=1 AND Y-INT (Y/3)*3=1 THEN RETURN
140 LET X=INT (X/3)
150 LET Y=INT (Y/3)
160 IF X>0 OR Y>0 THEN GOTO 130
170 LET C=1
180 RETURN


import Foundation
func sierpinski_carpet(n:Int) -> String {
    func middle(str:String) -> String {
        let spacer = str.stringByReplacingOccurrencesOfString("#", withString:" ", options:nil, range:nil)
        return str + spacer + str
    }

    var carpet = ["#"]
    for i in 1...n {
        let a = carpet.map{$0 + $0 + $0}
        let b = carpet.map(middle)
        carpet = a + b + a
    }
    return "\n".join(carpet)
}

println(sierpinski_carpet(3))


package require Tcl 8.5

proc map {lambda list} {
    foreach elem $list {
        lappend result [apply $lambda $elem]
    }
    return $result
}

proc sierpinski_carpet n {
    set carpet [list "#"]
    for {set i 1} {$i <= $n} {incr i} {
        set carpet [concat \
            [map {x {subst {$x$x$x}}} $carpet] \
            [map {x {subst {$x[string map {"#" " "} $x]$x}}} $carpet] \
            [map {x {subst {$x$x$x}}} $carpet] \
        ]
    }
    return [join $carpet \n]
}

puts [sierpinski_carpet 3]


Input "Carpet order: ";n

l = (3^n) - 1
For i = 0 To l
  For j = 0 To l
    Push i,j
    Gosub 100
    If Pop() Then
      Print "#";
    Else
      Print " ";
    EndIf
  Next
  Print
Next
End

100 y = Pop(): x = Pop() : Push 1

    Do While (x > 0) * (y > 0)
      If (x % 3 = 1) * (y % 3 = 1) Then
         Push (Pop() - 1)
         Break
      EndIf
      y = y / 3
      x = x / 3
    Loop

    Return


#!/bin/bash

sierpinski_carpet() {
    local -i n="${1:-3}"
    local carpet="${2:-#}"
    while (( n-- )); do
       local center="${carpet//#/ }"
       carpet="$(paste -d ' ' <(echo "$carpet"$'\n'"$carpet"$'\n'"$carpet")  <(echo "$carpet"$'\n'"$center"$'\n'"$carpet")  <(echo "$carpet"$'\n'"$carpet"$'\n'"$carpet"))"
    done
    echo "$carpet"
}


Const Order = 4

Function InCarpet(ByVal x As Integer, ByVal y As Integer)
    Do While x <> 0 And y <> 0
        If x Mod 3 = 1 And y Mod 3 = 1 Then
            InCarpet = " "
            Exit Function
        End If
        x = x \ 3
        y = y \ 3
    Loop
    InCarpet = "#"
End Function

Public Sub sierpinski_carpet()
    Dim i As Integer, j As Integer
    For i = 0 To 3 ^ Order - 1
        For j = 0 To 3 ^ Order - 1
            Debug.Print InCarpet(i, j);
        Next j
        Debug.Print
    Next i
End Sub


Function InCarpet(i,j)
	If i > 0 And j > 0 Then
		Do While i > 0 And j > 0
			If i Mod 3 = 1 And j Mod 3 = 1 Then
				InCarpet = " "
				Exit Do
			Else
				InCarpet = "#"
			End If
				i = Int(i / 3)
				j = Int(j / 3)
		Loop
	Else
		InCarpet = "#"
	End If
End Function

Function Carpet(n)
	k = 3^n - 1
	x2 = 0
	y2 = 0
	For y = 0 To k
		For x = 0 To k
			x2 = x
			y2 = y
			WScript.StdOut.Write InCarpet(x2,y2)
		Next
		WScript.StdOut.WriteBlankLines(1)
	Next
End Function

Carpet(WScript.Arguments(0))


var inCarpet = Fn.new { |x, y|
    while (true) {
        if (x == 0 || y == 0) return true
        if (x%3 == 1 && y%3 == 1) return false
        x = (x/3).floor
        y = (y/3).floor
    }
}

var carpet = Fn.new { |n|
    var power = 3.pow(n)
    for (i in 0...power) {
        for (j in 0...power) {
            System.write(inCarpet.call(i, j) ? "#" : " ")
        }
        System.print()
    }
}

carpet.call(3)


;x86-64 assembly code for Microsoft Windows
;Tested in windows 7 Enterprise Service Pack 1 64 bit
;With the AMD FX(tm)-6300 processor
;Assembled with NASM version 2.11.06
;Linked to C library with gcc version 4.9.2 (x86_64-win32-seh-rev1, Built by MinGW-W64 project)

;Assembled and linked with the following commands:
;nasm -f win64 <filename>.asm -o <filename>.obj
;gcc <filename>.obj -o <filename>

;Takes magnitude of Sierpinski Carpet as command line argument.

extern atoi,puts,putchar,exit

section .data
errmsg_noarg: db "Magnitude of Sierpinski Carpet was not specified.",0
errmsg_argnumber: db "There should be no more than one argument.",0

section .bss

section .text
global main

main:

;check for argument
cmp rcx,1
jle err_noarg

;ensure that only one argument was entered
cmp rcx,2
jg err_argnumber

;column in rsi
;row in rdi
;x in r8
;y in r9
;width in r13
;magic number in r14

mov r14,2863311531

;get magnitude in rbx from first arg
mov rcx,[rdx + 8]
call atoi
mov rbx,rax

cmp rbx,0
jz magnitude_zero

;determine dimensions of square
mov rax,1

find_width:

lea rax,[rax * 3]

dec rbx
jg find_width

sub rax,1

mov r13,rax
mov rdi,rax

next_row:

mov rsi,r13

fill_row:

;x in r8, y in r9
mov r8,rsi
mov r9,rdi

is_filled:

;if(x%3==1 && y%3==1)
;x%3 in rbx
mov rax,r8
mov rbx,r8
mul r14
shr rax,33
mov r8,rax
lea rax,[rax * 3]
sub rbx,rax

;y%3 in rcx
mov rax,r9
mov rcx,r9
mul r14
shr rax,33
mov r9,rax
lea rax,[rax * 3]
sub rcx,rax

;x%3==1 && y%3==1
xor rbx,1
xor rcx,1
or rbx,rcx
mov rcx,' '
cmp rbx,0
jz dont_fill

;x>0 || y>0
mov rax,r8
or rax,r9
cmp rax,0
jg is_filled

mov rcx,'#'
dont_fill:

call putchar

dec rsi
jge fill_row

;put newline at the end of each row
mov rcx,0xa
call putchar

dec rdi
jge next_row

xor rcx,rcx
call exit

magnitude_zero:

mov rcx,'#'
call putchar

mov rcx,0xa
call putchar

xor rcx,rcx
call exit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;error message

err_noarg:

mov rcx,errmsg_noarg
call puts

mov rcx,1
call exit

err_argnumber:

mov rcx,errmsg_argnumber
call puts

mov rcx,1
call exit


include c:\cxpl\codes;          \intrinsic 'code' declarations

proc DrawPat(X0, Y0, S);        \Draw 3x3 pattern with hole in middle
int  X0, Y0, S;                 \coordinate of upper-left corner, size
int  X, Y;
[for Y:= 0 to 2 do
    for X:= 0 to 2 do
        if X#1 or Y#1 then      \don't draw middle pattern
           [if S>1 then         \recurse
                DrawPat(X*S+X0, Y*S+Y0, S/3)
           else Point(X+X0, Y+Y0, 4\red\);
           ];
];

[SetVid($13);                   \set 320x200 graphic video mode
DrawPat(0, 0, 3*3*3);           \draw Sierpinski carpet
if ChIn(1) then [];             \wait for keystroke
SetVid($3);                     \restore normal text mode
]


sub sp$(n)
	local i, s$

	for i = 1 to n
		s$ = s$ + " "
	next i
	return s$
end sub

sub replace$(s$, cf$, cr$)
	local i, p

	do
		i = instr(s$, cf$, p)
		if not i break
		mid$(s$, i, 1) = cr$
		p = i
	loop
	return s$
end sub

sub foreach$(carpet$, p$, m)
	local n, i, t$(1)

	n = token(carpet$, t$(), ",")

	for i = 1 to n
		switch(m)
		case 0:	p$ = p$ + "," + t$(i) + t$(i) + t$(i) : break
		case 1: p$ = p$ + "," + t$(i) + sp$(len(t$(i))) + t$(i) : break
		default: error "Method not found!" : break
		end switch
	next i
	return p$
end sub

sub sierpinskiCarpet$(n)
    local carpet$, next$, i

    carpet$ = "@"
    for i = 1 to n
        next$ = foreach$(carpet$, "")
        next$ = foreach$(carpet$, next$, 1)
        carpet$ = foreach$(carpet$, next$)
    next i
    return carpet$
end sub

print replace$(sierpinskiCarpet$(3), ",", "\n")


; Sierpinski carpet in Z80 assembly (for CP/M OS - you can use `tnylpo` or `z88dk-ticks` on PC)
    OPT --syntax=abf : OUTPUT "sierpinc.com"    ; asm syntax for z00m's variant of sjasmplus
    ORG $100
    ; start for n=0, total size is 1x1 (just '#'), show five carpets for n=0,1,2,3,4
    ld h,%00000001      ; 3**0 = 1 in BCT form (0t0001)
carpets_loop:           ; n == 4 is maximum for 8bit BCT math (3**4 = 81 = 0x100 as BCT value)
    call show_carpet
    ld a,h              ; do ++n -> H = 3**n in BCT form, ie. `H <<= 2;` in binary way
    add a,a
    jp z,0              ; return to CP/M if the biggest carpet for n=4 (H==0) was already displayed
    add a,a
    ld h,a              ; zero for n=4, which will correctly wrap to 0t2222 in base3_dec_a
    jr carpets_loop

show_carpet:
    ld l,h              ; L = 3**n (row counter and Y coordinate)
.rows:
    ld a,l
    call base3_dec_a
    ld l,a              ; --L for this row
    ld b,h              ; B = 3**n (char counter and X coordinate)
.chars:
    ld a,b
    call base3_dec_a
    ld b,a              ; --B
    and l               ; check if X and Y coordinate have digit "1" at same position(s) in ternary
    and %01010101       ; non-zero if both coordinates have digit "1" at same position(s)
    ld e,'#'
    jr z,.fill_char
    ld e,' '
.fill_char:
    call print_char
    inc b
    djnz .chars         ; loop chars until B==0 was displayed
    call print_crlf
    ld a,l
    or a
    jr nz,.rows         ; loop rows until L==0 was displayed
    ; fallthrough into print_crlf for extra empty line after each carpet is finished
print_crlf:
    ld e,10
    call print_char
    ld e,13
print_char:
    push bc
    push hl
    ld c,2
    call 5
    pop hl
    pop bc
    ret

; in: A = BCT value (Binary-coded Ternary = pair of bits for ternary digit 0,1,2 (3 not allowed))
; out: A-1 in BCT encoding, modifies C and F (ZF signals zero result, 0t0000-1 = 0t2222 (0xAA))
base3_dec_a:
    dec a               ; --A (%00 digits may become %11 when involved in decrement)
    ld c,a
    rra
    and c
    and %01010101       ; %11 bit-pairs to %01, anything else to %00
    xor c               ; fix %11 -> %10 in result to have only 0,1,2 digits
    ret

/* ;;; bonus routine ;;;
; in: A = BCT value (Binary-coded Ternary = pair of bits for ternary digit 0,1,2 (3 not allowed))
; out: A+1 in BCT encoding, modifies C and F (ZF signals zero result, ie. 0t2222+1 = 0t0000)
base3_inc_a:
    add a,%01'01'01'10  ; +1 to every digit (0,1,2 -> 1,2,3), and +1 overall to increment
    ld c,a
    rra
    or c
    and %01'01'01'01    ; 00,01,10,11 -> 00,01,01,01
    neg
    add a,c             ; revert digits 3,2,1 back to 2,1,0 (0 -> 0)
    ret
*/


fcn drawPat(x0,y0,s,img){  // Draw 3x3 pattern with hole in middle
   foreach y,x in (3,3){
      if(x.isEven or y.isEven){	// don't draw middle pattern
	 if(s>1) self.fcn(x*s + x0, y*s + y0, s/3, img);	// recurse
	 else img[x + x0, y + y0]=0xff0000; // red
      }
   }
}


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program sha256_64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

.equ LGHASH, 32                  // result length

/*******************************************/
/* Structures                               */
/********************************************/
/* example structure  variables  */
    .struct  0
var_a:                     // a
    .struct  var_a + 4
var_b:                     // b
    .struct  var_b + 4
var_c:                     // c
    .struct  var_c + 4
var_d:                     // d
    .struct  var_d + 4
var_e:                     // e
    .struct  var_e + 4
var_f:                     // f
    .struct  var_f + 4
var_g:                     // g
    .struct  var_g + 4
var_h:                     // h
    .struct  var_h + 4

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessRosetta:        .asciz "Rosetta code"
szMessTest1:           .asciz "abc"
szMessSup64:           .ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                       .ascii "abcdefghijklmnopqrstuvwxyz"
                       .asciz "1234567890AZERTYUIOP"
szMessTest2:           .asciz "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
szMessFinPgm:          .asciz "Program End ok.\n"
szMessResult:          .asciz "Rosetta code => "
szCarriageReturn:   .asciz "\n"

/* array constantes Hi */
tbConstHi:           .int 0x6A09E667       // H0
                     .int 0xBB67AE85       // H1
                     .int 0x3C6EF372       // H2
                     .int 0xA54FF53A       // H3
                     .int 0x510E527F       // H4
                     .int 0x9B05688C       // H5
                     .int 0x1F83D9AB       // H6
                     .int 0x5BE0CD19       // H7
/* array  64 constantes Kt */
tbConstKt:
  .int 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5
  .int 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174
  .int 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da
  .int 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967
  .int 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85
  .int 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070
  .int 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3
  .int 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
.align 4
qNbBlocs:                    .skip 8
sZoneConv:                   .skip 24
sZoneTrav:                   .skip 1000
.align 8
tbH:                         .skip 4 * 8         // 8 variables H
tbabcdefgh:                  .skip 4 * 8
tbW:                         .skip 4 * 64        // 64 words W
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                      // entry of program

    ldr x0,qAdrszMessRosetta
    //ldr x0,qAdrszMessTest1
    //ldr x0,qAdrszMessTest2
    //ldr x0,qAdrszMessSup64
    bl computeSHA256                       // call routine SHA1

    ldr x0,qAdrszMessResult
    bl affichageMess                       // display message

    ldr x0, qAdrtbH
    bl displaySHA1

    ldr x0,qAdrszMessFinPgm
    bl affichageMess                       // display message

100:                                       // standard end of the program
    mov x0,0                               // return code
    mov x8,EXIT                            // request to exit program
    svc 0                                  // perform the system call

qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrszMessResult:         .quad szMessResult
qAdrszMessRosetta:        .quad szMessRosetta
qAdrszMessTest1:          .quad szMessTest1
qAdrszMessTest2:          .quad szMessTest2
qAdrsZoneTrav:            .quad sZoneTrav
qAdrsZoneConv:            .quad sZoneConv
qAdrszMessFinPgm:         .quad szMessFinPgm
qAdrszMessSup64:          .quad szMessSup64
/******************************************************************/
/*     compute SHA1                         */
/******************************************************************/
/* x0 contains the address of the message */
computeSHA256:
    stp x1,lr,[sp,-16]!      // save  registers
    ldr x1,qAdrsZoneTrav
    mov x2,#0                // counter length
debCopy:                     // copy string in work area
    ldrb w3,[x0,x2]
    strb w3,[x1,x2]
    cmp x3,#0
    add x4,x2,1
    csel x2,x4,x2,ne
    bne debCopy
    lsl x6,x2,#3             // initial message length in bits
    mov x3,#0b10000000       // add bit 1 at end of string
    strb w3,[x1,x2]
    add x2,x2,#1             // length in bytes
    str xzr,[x1,x2]          // zeroes in end of array
    lsl x4,x2,#3             // length in bits
addZeroes:
    lsr x5,x2,#6
    lsl x5,x5,#6
    sub x5,x2,x5
    cmp x5,#56
    beq storeLength          // yes -> end add
    str xzr,[x1,x2]          // add zero at message end
    add x2,x2,#1              // increment lenght bytes
    add x4,x4,#8             // increment length in bits
    b addZeroes
storeLength:
    add x2,x2,#4             // add four bytes
    rev w6,w6                // inversion bits initials message length
    str w6,[x1,x2]           // and store at end

    ldr x7,qAdrtbConstHi     // constantes H address
    ldr x4,qAdrtbH           // start area H
    mov x5,#0
loopConst:                   // init array H with start constantes
    ldr w6,[x7,x5,lsl #2]    // load constante
    str w6,[x4,x5,lsl #2]    // and store
    add x5,x5,#1
    cmp x5,#8
    blt loopConst
                             // split into block of 64 bytes
    add x2,x2,#4                //
    lsr x4,x2,#6             // blocks number
    ldr x0,qAdrqNbBlocs
    str x4,[x0]              // save block maxi
    mov x7,#0                // n° de block et x1 contient l adresse zone de travail
loopBlock:                   // begin loop of each block of 64 bytes
    mov x0,x7
    bl inversion             // inversion each word because little indian
    ldr x3,qAdrtbW           // working area W address
    mov x6,#0                // indice t
                             /* x2  address begin each block */
    ldr x1,qAdrsZoneTrav
    add x2,x1,x7,lsl #6      //  compute block begin  indice * 4 * 16

loopPrep:                    // loop for expand 80 words
    cmp x6,#15               //
    bgt expand1
    ldr w0,[x2,x6,lsl #2]    // load word message
    str w0,[x3,x6,lsl #2]    // store in first 16 block
    b expandEnd

expand1:
    sub x8,x6,#2
    ldr w9,[x3,x8,lsl #2]
    ror w10,w9,#17           // fonction e1 (256)
    ror w11,w9,#19
    eor w10,w10,w11
    lsr w11,w9,#10
    eor w10,w10,w11
    sub x8,x6,#7
    ldr w9,[x3,x8,lsl #2]
    add w9,w9,w10            // + w - 7
    sub x8,x6,#15
    ldr w10,[x3,x8,lsl #2]
    ror w11,w10,#7          // fonction e0 (256)
    ror w12,w10,#18
    eor w11,w11,w12
    lsr w12,w10,#3
    eor w10,w11,w12
    add w9,w9,w10
    sub x8,x6,#16
    ldr w11,[x3,x8,lsl #2]
    add w9,w9,w11

    str w9,[x3,x6,lsl #2]
expandEnd:
    add x6,x6,#1
    cmp x6,#64                 // 64 words ?
    blt loopPrep               // and loop

    /* COMPUTING THE MESSAGE DIGEST */
    /* x1  area H constantes address */
    /* x3  working area W address  */
    /* x5  address constantes K   */
    /* x6  counter t */
    /* x7  block counter */
    /* x8  addresse variables a b c d e f g h  */
                               // init variable a b c d e f g h
    ldr x0,qAdrtbH
    ldr x8,qAdrtbabcdefgh
    mov x1,#0
loopInita:
    ldr w9,[x0,x1,lsl #2]
    str w9,[x8,x1,lsl #2]
    add x1,x1,#1
    cmp x1,#8
    blt loopInita

    ldr x1,qAdrtbConstHi
    ldr x5,qAdrtbConstKt
    mov x6,#0
loop64T:                      // begin loop 64 t
    ldr w9,[x8,#var_h]
    ldr w10,[x8,#var_e]       // calcul T1
    ror w11,w10,#6            // fonction sigma 1
    ror w12,w10,#11
    eor w11,w11,w12
    ror w12,w10,#25
    eor w11,w11,w12
    add w9,w9,w11             // h + sigma1 (e)
    ldr w0,[x8,#var_f]        //  fonction ch  x and y xor (non x and z)
    ldr w4,[x8,#var_g]
    and w11,w10,w0
    mvn w12,w10
    and w12,w12,w4
    eor w11,w11,w12
    add w9,w9,w11             // h + sigma1 (e) + ch (e,f,g)
    ldr w0,[x5,x6,lsl #2]     // load constantes k0
    add w9,w9,w0
    ldr w0,[x3,x6,lsl #2]     // Wt
    add w9,w9,w0
                              // calcul T2
    ldr w10,[x8,#var_a]       // fonction sigma 0
    ror w11,w10,#2
    ror w12,w10,#13
    eor w11,w11,w12
    ror w12,w10,#22
    eor w11,w11,w12
    ldr w2,[x8,#var_b]
    ldr w4,[x8,#var_c]
                              // fonction maj x and y xor x and z xor y and z
    and w12,w10,w2
    and w0,w10,w4
    eor w12,w12,w0
    and w0,w2,w4
    eor w12,w12,w0            //
    add w12,w12,w11           // T2
                              // compute variables
    ldr w4,[x8,#var_g]
    str w4,[x8,#var_h]
    ldr w4,[x8,#var_f]
    str w4,[x8,#var_g]
    ldr w4,[x8,#var_e]
    str w4,[x8,#var_f]
    ldr w4,[x8,#var_d]
    add w4,w4,w9              // add T1
    str w4,[x8,#var_e]
    ldr w4,[x8,#var_c]
    str w4,[x8,#var_d]
    ldr w4,[x8,#var_b]
    str w4,[x8,#var_c]
    ldr w4,[x8,#var_a]
    str w4,[x8,#var_b]
    add w4,w9,w12             // add T1 T2
    str w4,[x8,#var_a]

    add x6,x6,#1              // increment t
    cmp x6,#64
    blt loop64T
                              // End block
    ldr x0,qAdrtbH            // start area H
    mov x10,#0
loopStoreH:
    ldr w9,[x8,x10,lsl #2]
    ldr w3,[x0,x10,lsl #2]
    add w3,w3,w9
    str w3,[x0,x10,lsl #2]    // store variables in H0
    add x10,x10,#1
    cmp x10,#8
    blt loopStoreH
                              // other bloc
    add x7,x7,#1                 // increment block
    ldr x0,qAdrqNbBlocs
    ldr x4,[x0]               // restaur maxi block
    cmp x7,x4                 // maxi ?

    blt loopBlock             //  loop other block

    ldr x0,qAdrtbH            // return result address

100:
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30
qAdrtbConstHi:            .quad tbConstHi
qAdrtbConstKt:            .quad tbConstKt
qAdrtbH:                  .quad tbH
qAdrtbW:                  .quad tbW
qAdrtbabcdefgh:           .quad tbabcdefgh
qAdrqNbBlocs:             .quad qNbBlocs
/******************************************************************/
/*     inversion des mots de 32 bits d un bloc                    */
/******************************************************************/
/* x0 contains N° block   */
inversion:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    ldr x1,qAdrsZoneTrav
    add x1,x1,x0,lsl #6           // debut du bloc
    mov x2,#0
1:                                                  // start loop
    ldr w3,[x1,x2,lsl #2]
    rev w3,w3
    str w3,[x1,x2,lsl #2]
    add x2,x2,#1
    cmp x2,#16
    blt 1b
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     display hash  SHA1                         */
/******************************************************************/
/* x0 contains the address of hash  */
displaySHA1:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x3,x0
    mov x2,#0
1:
    ldr w0,[x3,x2,lsl #2]          // load 4 bytes
    //rev x0,x0                    // reverse bytes
    ldr x1,qAdrsZoneConv
    bl conversion16_4W             // conversion hexa
    ldr x0,qAdrsZoneConv
    bl affichageMess
    add x2,x2,#1
    cmp x2,#LGHASH / 4
    blt 1b                         // and loop
    ldr x0,qAdrszCarriageReturn
    bl affichageMess               // display message
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     conversion  hexadecimal register 32 bits                   */
/******************************************************************/
/* x0 contains value and x1 address zone receptrice   */
conversion16_4W:
    stp x0,lr,[sp,-48]!        // save  registres
    stp x1,x2,[sp,32]          // save  registres
    stp x3,x4,[sp,16]          // save  registres
    mov x2,#28                 // start bit position
    mov x4,#0xF0000000         // mask
    mov x3,x0                  // save entry value
1:                             // start loop
    and x0,x3,x4               // value register and mask
    lsr x0,x0,x2               // right shift
    cmp x0,#10                 // >= 10 ?
    bge 2f                     // yes
    add x0,x0,#48              // no is digit
    b 3f
2:
    add x0,x0,#55              // else is a letter A-F
3:
    strb w0,[x1],#1            // load result  and + 1 in address
    lsr x4,x4,#4               // shift mask 4 bits left
    subs x2,x2,#4              // decrement counter 4 bits <= zero  ?
    bge 1b                     // no -> loop

100:                           // fin standard de la fonction
    ldp x3,x4,[sp,16]          // restaur des  2 registres
    ldp x1,x2,[sp,32]          // restaur des  2 registres
    ldp x0,lr,[sp],48          // restaur des  2 registres
    ret
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


with Ada.Text_IO;

with CryptAda.Pragmatics;
with CryptAda.Digests.Message_Digests.SHA_256;
with CryptAda.Digests.Hashes;
with CryptAda.Utils.Format;

procedure RC_SHA_256 is
   use CryptAda.Pragmatics;
   use CryptAda.Digests.Message_Digests;
   use CryptAda.Digests;

   function To_Byte_Array (Item : String) return Byte_Array is
      Result : Byte_Array (Item'Range);
   begin
      for I in Result'Range loop
         Result (I) := Byte (Character'Pos (Item (I)));
      end loop;
      return Result;
   end To_Byte_Array;

   Text    : constant String                := "Rosetta code";
   Bytes   : constant Byte_Array            := To_Byte_Array (Text);
   Handle  : constant Message_Digest_Handle := SHA_256.Get_Message_Digest_Handle;
   Pointer : constant Message_Digest_Ptr    := Get_Message_Digest_Ptr (Handle);
   Hash    : Hashes.Hash;
begin
   Digest_Start  (Pointer);
   Digest_Update (Pointer, Bytes);
   Digest_End    (Pointer, Hash);

   Ada.Text_IO.Put_Line
     ("""" & Text & """: " & CryptAda.Utils.Format.To_Hex_String (Hashes.Get_Bytes (Hash)));
end RC_SHA_256;