WeixiangYan/CodeTransOcean huggingface dataset:
Task: Kronecker product based fractals


C++: #include <cassert>
#include <vector>

#include <QImage>

template <typename scalar_type> class matrix {
public:
    matrix(size_t rows, size_t columns)
        : rows_(rows), columns_(columns), elements_(rows * columns) {}
    matrix(size_t rows, size_t columns,
        const std::initializer_list<std::initializer_list<scalar_type>>& values)
        : rows_(rows), columns_(columns), elements_(rows * columns) {
        assert(values.size() <= rows_);
        size_t i = 0;
        for (const auto& row : values) {
            assert(row.size() <= columns_);
            std::copy(begin(row), end(row), &elements_[i]);
            i += columns_;
        }
    }
    size_t rows() const { return rows_; }
    size_t columns() const { return columns_; }

    const scalar_type& operator()(size_t row, size_t column) const {
        assert(row < rows_);
        assert(column < columns_);
        return elements_[row * columns_ + column];
    }
    scalar_type& operator()(size_t row, size_t column) {
        assert(row < rows_);
        assert(column < columns_);
        return elements_[row * columns_ + column];
    }
private:
    size_t rows_;
    size_t columns_;
    std::vector<scalar_type> elements_;
};


template <typename scalar_type>
matrix<scalar_type> kronecker_product(const matrix<scalar_type>& a,
                                      const matrix<scalar_type>& b) {
    size_t arows = a.rows();
    size_t acolumns = a.columns();
    size_t brows = b.rows();
    size_t bcolumns = b.columns();
    matrix<scalar_type> c(arows * brows, acolumns * bcolumns);
    for (size_t i = 0; i < arows; ++i)
        for (size_t j = 0; j < acolumns; ++j)
            for (size_t k = 0; k < brows; ++k)
                for (size_t l = 0; l < bcolumns; ++l)
                    c(i*brows + k, j*bcolumns + l) = a(i, j) * b(k, l);
    return c;
}

bool kronecker_fractal(const char* fileName, const matrix<unsigned char>& m, int order) {
    matrix<unsigned char> result = m;
    for (int i = 0; i < order; ++i)
        result = kronecker_product(result, m);

    size_t height = result.rows();
    size_t width = result.columns();
    size_t bytesPerLine = 4 * ((width + 3)/4);
    std::vector<uchar> imageData(bytesPerLine * height);

    for (size_t i = 0; i < height; ++i)
        for (size_t j = 0; j < width; ++j)
            imageData[i * bytesPerLine + j] = result(i, j);

    QImage image(&imageData[0], width, height, bytesPerLine, QImage::Format_Indexed8);
    QVector<QRgb> colours(2);
    colours[0] = qRgb(0, 0, 0);
    colours[1] = qRgb(255, 255, 255);
    image.setColorTable(colours);
    return image.save(fileName);
}

int main() {
    matrix<unsigned char> matrix1(3, 3, {{0,1,0}, {1,1,1}, {0,1,0}});
    matrix<unsigned char> matrix2(3, 3, {{1,1,1}, {1,0,1}, {1,1,1}});
    matrix<unsigned char> matrix3(2, 2, {{1,1}, {0,1}});
    kronecker_fractal("vicsek.png", matrix1, 5);
    kronecker_fractal("sierpinski_carpet.png", matrix2, 5);
    kronecker_fractal("sierpinski_triangle.png", matrix3, 8);
    return 0;
}
Task: Shortest common supersequence


C++: #include <iostream>

std::string scs(std::string x, std::string y) {
    if (x.empty()) {
        return y;
    }
    if (y.empty()) {
        return x;
    }
    if (x[0] == y[0]) {
        return x[0] + scs(x.substr(1), y.substr(1));
    }
    if (scs(x, y.substr(1)).size() <= scs(x.substr(1), y).size()) {
        return y[0] + scs(x, y.substr(1));
    } else {
        return x[0] + scs(x.substr(1), y);
    }
}

int main() {
    auto res = scs("abcbdab", "bdcaba");
    std::cout << res << '\n';
    return 0;
}
Task: Long year






PHP: function isLongYear($year) {
  return (53 == strftime('%V', gmmktime(0,0,0,12,28,$year)));
}

for ($y=1995; $y<=2045; ++$y) {
  if (isLongYear($y)) {
    printf("%s\n", $y);
  }
}
Task: Long year








VB: Public Sub Main() 
  
  For y As Integer = 2000 To 2100 
    If isLongYear(y) Then Print y, 
  Next
  
End 

Function p(y As Integer) As Integer 
  
  Return (y + (y \ 4) - (y \ 100) + (y \ 400)) Mod 7 
  
End Function 

Function isLongYear(y As Integer) As Boolean 
  
  If p(y) = 4 Then Return True 
  If p(y - 1) = 3 Then Return True 
  Return False 
  
End Function
Task: Mian-Chowla sequence








VB: 
    Const m = 100, mm=28000
    ReDim r(mm), v(mm * 2)
    Dim n, t, i, j, l, s1, s2, iterate_t
    ReDim seq(m)
    t0=Timer
    s1 = "1": s2 = ""
    seq(1) = 1: n = 1: t = 1
    Do While n < m
        t = t + 1
        iterate_t = False
        For i = 1 to t * 2
            v(i) = 0
        Next
        i = 1
        Do While i <= t And Not iterate_t
            If r(i) = 0 Then
                j = i
                Do While j <= t And Not iterate_t
                    If r(j) = 0 Then
                        l = i + j
                        If v(l) = 1 Then
                            r(t) = 1
                            iterate_t = True
                        End If
                        If Not iterate_t Then v(l) = 1
                    End If
                    j = j + 1
                Loop
            End If
            i = i + 1
        Loop
        If Not iterate_t Then
            n = n + 1
            seq(n) = t
            if           n<= 30 then s1 = s1 & " " & t
            if n>=91 and n<=100 then s2 = s2 & " " & t
        End If
    Loop
    wscript.echo "t="& t
    wscript.echo "The Mian-Chowla sequence for elements 1 to 30:"
    wscript.echo s1
    wscript.echo "The Mian-Chowla sequence for elements 91 to 100:"
    wscript.echo s2
    wscript.echo "Computation time: "&  Int(Timer-t0) &" sec"
Task: Two identical strings








VB: Imports System.Console
Module Module1
  Sub Main()
    Dim p, c, k, lmt as integer : p = 2 : lmt = 1000
    For n As Integer = 1 to lmt
      p += If(n >= p, p, 0) : k = n + n * p
      If k > lmt Then Exit For Else c += 1
      Write("{0,3} ({1,-10})  {2}", k, Convert.ToString( k, 2),
          If(c Mod 5 = 0, vbLf, ""))
    Next : WriteLine(vbLf + "Found {0} numbers whose base 2 representation is the concatenation of two identical binary strings.", c)
  End Sub
End Module
Task: Call a foreign-language function








VB:   Declare Function CreateFileW Lib "Kernel32" (FileName As WString, DesiredAccess As Integer, ShareMode As Integer, SecurityAttributes As Integer, _
        CreateDisposition As Integer, Flags As Integer, Template As Integer) As Integer
  Declare Function WriteFile Lib "Kernel32" (fHandle As Integer, writeData As Ptr, numOfBytes As Integer, ByRef numOfBytesWritten As Integer, _
        overlapped As Ptr) As Boolean
  Declare Function GetLastError Lib "Kernel32" () As Integer
  Declare Function CloseHandle Lib "kernel32" (hObject As Integer) As Boolean
  
  Const FILE_SHARE_READ = &h00000001
  Const FILE_SHARE_WRITE = &h00000002
  Const OPEN_EXISTING = 3
  
  Dim fHandle As Integer = CreateFileW("C:\foo.txt", 0,  FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
  If fHandle > 0 Then
    Dim mb As MemoryBlock = "Hello, World!"
    Dim bytesWritten As Integer
    If Not WriteFile(fHandle, mb, mb.Size, bytesWritten, Nil) Then
      MsgBox("Error Number: " + Str(GetLastError))
    End If
    Call CloseHandle(fHandle)
  Else
    MsgBox("Error Number: " + Str(GetLastError))
  End If
Task: Change e letters to i in words








VB: with createobject("ADODB.Stream")
  .charset ="UTF-8"
  .open
  .loadfromfile("unixdict.txt")
  s=.readtext
end with  
a=split (s,vblf)
set d=createobject("scripting.dictionary")
redim b(ubound(a))
i=0
for each x in a
  s=trim(x)
  if len(s)>5 then 
    if instr(s,"i") then d.add s,""
    if instr(s,"e") then b(i)=s:  i=i+1   
  end if
next
redim preserve b(i-1)

for i=0 to ubound(b)
  s=trim(b(i))
  s2=replace(s,"e","i")
  if d.exists(s2) then 
    wscript.echo left(s& space(10),10) & "-> " & s2
  end if 
next
Task: Boolean values








VB: Dim a As Integer
Dim b As Boolean
Debug.Print b
a = b
Debug.Print a
b = True
Debug.Print b
a = b
Debug.Print a
Task: Bioinformatics_base count








VB: b=_  
"CGTAAAAAATTACAACGTCCTTTGGCTATCTCTTAAACTCCTGCTAAATG" &_
"CTCGTGCTTTCCAATTATGTAAGCGTTCCGAGACGGGGTGGTCGATTCTG" &_
"AGGACAAAGGTCAAGATGGAGCGCATCGAACGCAATAAGGATCATTTGAT" &_
"GGGACGTTTCGTCGACAAAGTCTTGTTTCGAGAGTAACGGCTACCGTCTT" &_
"CGATTCTGCTTATAACACTATGTTCTTATGAAATGGATGTTCTGAGTTGG" &_
"TCAGTCCCAATGTGCGGGGTTTCTTTTAGTACGTCGGGAGTGGTATTATA" &_
"TTTAATTTTTCTATATAGCGATCTGTATTTAAGCAATTCATTTAGGTTAT" &_
"CGCCGCGATGCTCGGTTCGGACCGCCAAGCATCTGGCTCCACTGCTAGTG" &_
"TCCTAAATTTGAATGGCAAACACAAATAAGATTTAGCAATTCGTGTAGAC" &_
"GACCGGGGACTTGCATGATGGGAGCAGCTTTGTTAAACTACGAACGTAAT"

s="SEQUENCE:"
acnt=0:ccnt=0:gcnt=0:tcnt=0
 
for i=0 to len(b)-1
  if (i mod 30)=0 then s = s & vbcrlf & right("   "& i+1,3)&": " 
  if (i mod 5)=0 then s=s& " "
  m=mid(b,i+1,1)  
  s=s & m
  select case m
  case "A":acnt=acnt+1
  case "C":ccnt=ccnt+1
  case "G":gcnt=gcnt+1
  case "T":tcnt=tcnt+1
  case else
     wscript.echo "error at ",i+1, m 
  end select
next  
wscript.echo s & vbcrlf
wscript.echo "Count: A="&acnt & " C=" & ccnt & " G=" & gcnt & " T=" & tcnt
Task: Magic squares of odd order








VB: Sub magicsquare()
    
    Const n = 9
    Dim i As Integer, j As Integer, v As Integer
    Debug.Print "The square order is: " & n
    For i = 1 To n
        For j = 1 To n
            Cells(i, j) = ((i * 2 - j + n - 1) Mod n) * n + ((i * 2 + j - 2) Mod n) + 1
        Next j
    Next i
    Debug.Print "The magic number of"; n; "x"; n; "square is:"; n * (n * n + 1) \ 2
End Sub
Task: Pascal matrix generation








VB: Option Base 1
Private Function pascal_upper(n As Integer)
    Dim res As Variant: ReDim res(n, n)
    For j = 1 To n
        res(1, j) = 1
    Next j
    For i = 2 To n
        res(i, 1) = 0
        For j = 2 To i
            res(j, i) = res(j, i - 1) + res(j - 1, i - 1)
        Next j
        For j = i + 1 To n
            res(j, i) = 0
        Next j
    Next i
    pascal_upper = res
End Function
 
Private Function pascal_symmetric(n As Integer)
    Dim res As Variant: ReDim res(n, n)
    For i = 1 To n
        res(i, 1) = 1
        res(1, i) = 1
    Next i
    For i = 2 To n
        For j = 2 To n
            res(i, j) = res(i - 1, j) + res(i, j - 1)
        Next j
    Next i
    pascal_symmetric = res
End Function

Private Sub pp(m As Variant)
    For i = 1 To UBound(m)
        For j = 1 To UBound(m, 2)
            Debug.Print Format(m(i, j), "@@@");
        Next j
        Debug.Print
    Next i
End Sub

Public Sub main()
    Debug.Print "=== Pascal upper matrix ==="
    pp pascal_upper(5)
    Debug.Print "=== Pascal lower matrix ==="
    pp WorksheetFunction.Transpose(pascal_upper(5))
    Debug.Print "=== Pascal symmetrical matrix ==="
    pp pascal_symmetric(5)
End Sub
Task: Kahan summation








VB: Module Module1

    Function KahanSum(ParamArray fa As Single()) As Single
        Dim sum = 0.0F
        Dim c = 0.0F
        For Each f In fa
            Dim y = f - c
            Dim t = sum + y
            c = (t - sum) - y
            sum = t
        Next
        Return sum
    End Function

    Function Epsilon() As Single
        Dim eps = 1.0F
        While 1.0F + eps <> 1.0F
            eps /= 2.0F
        End While
        Return eps
    End Function

    Sub Main()
        Dim a = 1.0F
        Dim b = Epsilon()
        Dim c = -b
        Console.WriteLine("Epsilon      = {0}", b)
        Console.WriteLine("(a + b) + c  = {0}", (a + b) + c)
        Console.WriteLine("Kahan sum    = {0}", KahanSum(a, b, c))
    End Sub

End Module
Task: Text between








VB: Option Explicit

Private Const STRING_START As String = "Start"
Private Const STRING_END As String = "End"

Sub Main()
Dim Text As String, First As String, Last As String, Output As String

    Text = "Hello Rosetta Code world"
        First = "Hello "
            Last = " world"
    Output = "1- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "Hello Rosetta Code world"
        First = "Start"
            Last = " world"
    Output = Output & "2- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "Hello Rosetta Code world"
        First = "Hello "
            Last = "End"
    Output = Output & "3- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "</div><div style=\""chinese\"">你好嗎</div>..."
        First = "<div style=\""chinese\"">"
            Last = "</div>"
    Output = Output & "4- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "<text>Hello <span>Rosetta Code</span> world</text><table style=\""myTable\"">"
        First = "<text>"
            Last = "<table>"
    Output = Output & "5- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "<table style=\""myTable\""><tr><td>hello world</td></tr></table>"
        First = "<table>"
            Last = "</table>"
    Output = Output & "6- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "The quick brown fox jumps over the lazy other fox"
        First = "quick "
            Last = " fox"
    Output = Output & "7- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "One fish two fish red fish blue fish"
        First = "fish "
            Last = " red"
    Output = Output & "8- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "FooBarBazFooBuxQuux"
        First = "Foo"
            Last = "Foo"
    Output = Output & "9- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "</div><div style=\""chinese\"">你好嗎..."
        First = "<div style=\""chinese\"">"
            Last = "</div>"
    Output = Output & "10- " & Text_Between(Text, First, Last) & vbCrLf

    Text = ""
        First = "Start"
            Last = "End"
    Output = Output & "11- " & Text_Between(Text, First, Last) & vbCrLf

    Text = "Hello Rosetta Code world"
        First = "Start"
            Last = "End"
    Output = Output & "12- " & Text_Between(Text, First, Last)

    Debug.Print Output
End Sub

Private Function Text_Between(T$, F$, L$) As String
Dim i As Long
    i = InStr(T, L) + 1
    Select Case True
        Case T = "", F = "", InStr(T, F) = 0 And F <> STRING_START
            Text_Between = ""
        Case F = STRING_START And L = STRING_END
            Text_Between = T
        Case F = STRING_START
            Text_Between = Mid(T, 1, InStr(T, L) - 1)
        Case L = STRING_END, InStr(T, L) = 0, InStr(T, L) < InStr(T, F) And InStr(i, T, L) = 0
            Text_Between = Mid(T, Len(F) + InStr(T, F))
        Case F = L
            Text_Between = Mid(T, Len(F) + InStr(T, F), InStr(i, T, F) - Len(F) - 1)
        Case Else
            Text_Between = Mid(T, Len(F) + InStr(T, F), InStr(InStr(T, F), T, L) - (Len(F) + InStr(T, F)))
    End Select
End Function
Task: Pentagram








VB: Sub pentagram()
    With ActiveSheet.Shapes.AddShape(msoShape5pointStar, 10, 10, 400, 400)
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.Weight = 3
        .Line.ForeColor.RGB = RGB(0, 0, 255)
    End With
End Sub
Task: Verify distribution uniformity_Chi-squared test








VB: Private Function Test4DiscreteUniformDistribution(ObservationFrequencies() As Variant, Significance As Single) As Boolean
    
    Dim Total As Long, Ei As Long, i As Integer
    Dim ChiSquared As Double, DegreesOfFreedom As Integer, p_value As Double
    Debug.Print "[1] ""Data set:"" ";
    For i = LBound(ObservationFrequencies) To UBound(ObservationFrequencies)
        Total = Total + ObservationFrequencies(i)
        Debug.Print ObservationFrequencies(i); " ";
    Next i
    DegreesOfFreedom = UBound(ObservationFrequencies) - LBound(ObservationFrequencies)
    
    Ei = Total / (DegreesOfFreedom + 1)
    For i = LBound(ObservationFrequencies) To UBound(ObservationFrequencies)
        ChiSquared = ChiSquared + (ObservationFrequencies(i) - Ei) ^ 2 / Ei
    Next i
    p_value = 1 - WorksheetFunction.ChiSq_Dist(ChiSquared, DegreesOfFreedom, True)
    Debug.Print
    Debug.Print "   Chi-squared test for given frequencies"
    Debug.Print "X-squared ="; ChiSquared; ", ";
    Debug.Print "df ="; DegreesOfFreedom; ", ";
    Debug.Print "p-value = "; Format(p_value, "0.0000")
    Test4DiscreteUniformDistribution = p_value > Significance
End Function
Public Sub test()
    Dim O() As Variant
    O = [{199809,200665,199607,200270,199649}]
    Debug.Print "[1] ""Uniform? "; Test4DiscreteUniformDistribution(O, 0.05); """"
    O = [{522573,244456,139979,71531,21461}]
    Debug.Print "[1] ""Uniform? "; Test4DiscreteUniformDistribution(O, 0.05); """"
End Sub
Task: Extensible prime generator








VB: Option Explicit

Sub Main()
Dim Primes() As Long, n As Long, temp$
Dim t As Single
    t = Timer
    
    n = 133218295 
    Primes = ListPrimes(n)
    Debug.Print "For N = " & Format(n, "#,##0") & ", execution time : " & _
        Format(Timer - t, "0.000 s") & ", " & _
        Format(UBound(Primes) + 1, "#,##0") & " primes numbers."
    
    
    For n = 0 To 19
        temp = temp & ", " & Primes(n)
    Next
    Debug.Print "First twenty primes : "; Mid(temp, 3)
    
    n = 0: temp = vbNullString
    Do While Primes(n) < 100
        n = n + 1
    Loop
    Do While Primes(n) < 150
        temp = temp & ", " & Primes(n)
        n = n + 1
    Loop
    Debug.Print "Primes between 100 and 150 : " & Mid(temp, 3)
    
    Dim ccount As Long
    n = 0
    Do While Primes(n) < 7700
        n = n + 1
    Loop
    Do While Primes(n) < 8000
        ccount = ccount + 1
        n = n + 1
    Loop
    Debug.Print "Number of primes between 7,700 and 8,000 : " & ccount
    
    n = 1
    Do While n <= 100000
        n = n * 10
        Debug.Print "The " & n & "th prime: "; Format(Primes(n - 1), "#,##0")
    Loop
    Debug.Print "VBA has a limit in array
    Debug.Print "With my computer, the limit for an array of Long is : 133 218 295"
    Debug.Print "The last prime I could find is the : " & _
        Format(UBound(Primes), "#,##0") & "th, Value : " & _
        Format(Primes(UBound(Primes)), "#,##0")
End Sub

Function ListPrimes(MAX As Long) As Long()
Dim t() As Boolean, L() As Long, c As Long, s As Long, i As Long, j As Long
    ReDim t(2 To MAX)
    ReDim L(MAX \ 2)
    s = Sqr(MAX)
    For i = 3 To s Step 2
        If t(i) = False Then
            For j = i * i To MAX Step i
                t(j) = True
            Next
        End If
    Next i
    L(0) = 2
    For i = 3 To MAX Step 2
        If t(i) = False Then
            c = c + 1
            L(c) = i
        End If
    Next i
    ReDim Preserve L(c)
    ListPrimes = L
End Function
Task: Fractran








VB: Option Base 1
Public prime As Variant
Public nf As New Collection
Public df As New Collection
Const halt = 20
Private Sub init()
    prime = [{2,3,5,7,11,13,17,19,23,29,31}]
End Sub
Private Function factor(f As Long) As Variant
    Dim result(10) As Integer
    Dim i As Integer: i = 1
    Do While f > 1
        Do While f Mod prime(i) = 0
            f = f \ prime(i)
            result(i) = result(i) + 1
        Loop
        i = i + 1
    Loop
    factor = result
End Function
Private Function decrement(ByVal a As Variant, b As Variant) As Variant
    For i = LBound(a) To UBound(a)
        a(i) = a(i) - b(i)
    Next i
    decrement = a
End Function
Private Function increment(ByVal a As Variant, b As Variant) As Variant
    For i = LBound(a) To UBound(a)
        a(i) = a(i) + b(i)
    Next i
    increment = a
End Function
Private Function test(a As Variant, b As Variant)
    flag = True
    For i = LBound(a) To UBound(a)
        If a(i) < b(i) Then
            flag = False
            Exit For
        End If
    Next i
    test = flag
End Function
Private Function unfactor(x As Variant) As Long
    result = 1
    For i = LBound(x) To UBound(x)
        result = result * prime(i) ^ x(i)
    Next i
    unfactor = result
End Function
Private Sub compile(program As String)
    program = Replace(program, " ", "")
    programlist = Split(program, ",")
    For Each instruction In programlist
        parts = Split(instruction, "/")
        nf.Add factor(Val(parts(0)))
        df.Add factor(Val(parts(1)))
    Next instruction
End Sub
Private Function run(x As Long) As Variant
    n = factor(x)
    counter = 0
    Do While True
        For i = 1 To df.Count
            If test(n, df(i)) Then
                n = increment(decrement(n, df(i)), nf(i))
                Exit For
            End If
        Next i
        Debug.Print unfactor(n);
        counter = counter + 1
        If num = 31 Or counter >= halt Then Exit Do
    Loop
    Debug.Print
    run = n
End Function
Private Function steps(x As Variant) As Variant
    
    For i = 1 To df.Count
        If test(x, df(i)) Then
            x = increment(decrement(x, df(i)), nf(i))
            Exit For
        End If
    Next i
    steps = x
End Function
Private Function is_power_of_2(x As Variant) As Boolean
    flag = True
    For i = LBound(x) + 1 To UBound(x)
        If x(i) > 0 Then
            flag = False
            Exit For
        End If
    Next i
    is_power_of_2 = flag
End Function
Private Function filter_primes(x As Long, max As Integer) As Long
    n = factor(x)
    i = 0: iterations = 0
    Do While i < max
        If is_power_of_2(steps(n)) Then
            Debug.Print n(1);
            i = i + 1
        End If
        iterations = iterations + 1
    Loop
    Debug.Print
    filter_primes = iterations
End Function
Public Sub main()
    init
    compile ("17/91, 78/85, 19/51, 23/38, 29/33, 77/29, 95/23, 77/19, 1/17, 11/13, 13/11, 15/14,  15/2, 55/1")
    Debug.Print "First 20 results:"
    output = run(2)
    Debug.Print "First 30 primes:"
    Debug.Print "after"; filter_primes(2, 30); "iterations."
End Sub
Task: Peano curve








VB: Const WIDTH = 243 
Dim n As Long
Dim points() As Single
Dim flag As Boolean












Private Sub lineto(x As Integer, y As Integer)
    If flag Then
        points(n, 1) = x
        points(n, 2) = y
    End If
    n = n + 1
End Sub
Private Sub Peano(ByVal x As Integer, ByVal y As Integer, ByVal lg As Integer, _
    ByVal i1 As Integer, ByVal i2 As Integer)
    If (lg = 1) Then
        Call lineto(x * 3, y * 3)
        Exit Sub
    End If
    lg = lg / 3
    Call Peano(x + (2 * i1 * lg), y + (2 * i1 * lg), lg, i1, i2)
    Call Peano(x + ((i1 - i2 + 1) * lg), y + ((i1 + i2) * lg), lg, i1, 1 - i2)
    Call Peano(x + lg, y + lg, lg, i1, 1 - i2)
    Call Peano(x + ((i1 + i2) * lg), y + ((i1 - i2 + 1) * lg), lg, 1 - i1, 1 - i2)
    Call Peano(x + (2 * i2 * lg), y + (2 * (1 - i2) * lg), lg, i1, i2)
    Call Peano(x + ((1 + i2 - i1) * lg), y + ((2 - i1 - i2) * lg), lg, i1, i2)
    Call Peano(x + (2 * (1 - i1) * lg), y + (2 * (1 - i1) * lg), lg, i1, i2)
    Call Peano(x + ((2 - i1 - i2) * lg), y + ((1 + i2 - i1) * lg), lg, 1 - i1, i2)
    Call Peano(x + (2 * (1 - i2) * lg), y + (2 * i2 * lg), lg, 1 - i1, i2)
End Sub
Sub main()
    n = 1: flag = False
    Call Peano(0, 0, WIDTH, 0, 0) 
    ReDim points(1 To n - 1, 1 To 2)
    n = 1: flag = True
    Call Peano(0, 0, WIDTH, 0, 0) 
    ActiveSheet.Shapes.AddPolyline points 
End Sub