Squares

[dodicat]

Some Newton Interference:

Code: Select all

screenres 500,500,8,,&h08
#define dist(x1,y1,x2,y2) sqr( (x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
dim as integer kx1=1,ky1=1,kx2=-1,ky2=-1
dim as single dx1=.8,dy1=.9,dx2=.9,dy2=.8
dim as single px1=100,py1=100,px2=400,py2=400
dim as ubyte ptr pix=screenptr
dim as integer inc
do
inc=0
px1=px1+kx1*dx1:py1=py1+ky1*dy1
px2=px2+kx2*dx2:py2=py2+ky2*dy2
if px1<0 or px1>500 then kx1=-kx1
if py1<0 or py1>500 then ky1=-ky1
if px2<0 or px2>500 then kx2=-kx2
if py2<0 or py2>500 then ky2=-ky2

screenlock
cls
for y as integer=0 to 499
    for x as integer=0 to 499
        dim as single d=dist(x,y,px1,py2)
        dim as single d2=dist(x,y,px2,py1)
        pix[inc]=map(0,10000,x*d-y*d2,1,16)
        inc=inc+1
    next x
next y
screenunlock
sleep 1,1
loop until len(inkey)
     

[integer]

from dodicat:

But it is convenient because you can have a fast stand alone macro, and a macro is faster than a function.

as coded the macro requires twice the time as the function call.
IF you change the "as long" to "as double" then then macro version is faster.

What is a surprise:

Code: Select all

sum=Isquare2(z)+sum

is a few nanoseconds faster than

Code: Select all

sum=1/(z^2)+sum

[dodicat]

Yes integer.
The way the macro pans out is:
t1=timer
for z as long=1 to 500000
sum=sum+ 1/(z^2)
next z
t2=timer.

So it was an unfair comparison.

But the world was a slightly better place back then in 10 was it not?

Whatever happened to your multivariable chinese remainder procedure, did you complete it?

I've set martices into a udt rather than use direct array doubles.
It is only a mess around really, I much prefer using straight arrays.

Code: Select all

Type vector
    Dim As Double element(1 To 100)
    As Integer row
    Declare Operator Cast() As String
End Type

Type matrix 
    Dim As Double element(1 To 100,1 To 100)
    As Integer row,col
    Declare Operator Cast() As String
    Declare Property inverse() As matrix
    declare function GaussJordan(as vector) as vector
End Type

'rounding function
Function round (a As Double,b As Integer) As Double 
    Var y = (Abs(a)-Int(Abs(a))) * (10 ^ b),i=Int(y):y-=i
    If y >= .5 Then i+= 1 
    i /= (10 ^ b)
    Var r = Int(Abs(a))+i
    If a < 0 Then r = -r
    return r
End Function


Operator vector.cast() As String 'for printing
Dim As String ans
ans= "Solution:"+Chr(10)
For n As Integer=1 To row
    ans=ans+ Str(round(element(n),9))+Chr(10)
Next n
Operator =ans
End Operator

Operator matrix.cast() As String 'for printing
Dim As String ans,comma
For a As Integer=1 To row
    For b As Integer=1 To col
        If b=col Then comma="" Else comma=" , "
        ans=ans+Str(round(element(a,b),9))+comma
    Next b
    ans=ans+Chr(10)
Next a
operator= ans
End Operator

Operator *(m1 As matrix,m2 As matrix) As matrix
Dim rows As Integer=m1.row
Dim columns As Integer=m2.col
If m1.col<>m2.row Then
    Print "Can't do"
    Exit Operator
End If
static As matrix ans
ans.row=rows:ans.col=columns
Dim rxc As Double
For r As Integer=1 To rows
    For c As Integer=1 To columns
        rxc=0
        For k As Integer = 1 To m1.col
            rxc=rxc+m1.element(r,k)*m2.element(k,c)
        Next k
        ans.element(r,c)=rxc
    Next c
Next r
operator= ans
End Operator

Function matrix.GaussJordan(rhs As vector) As vector
    Dim As Integer n=row
    static As vector ans
    static as vector r:r=rhs
    static as matrix b:b=this
    #macro pivot(num)
    For p1 As Integer  = num To n - 1
        For p2 As Integer  = p1 + 1 To n  
            If Abs(b.element(p1,num))<Abs(b.element(p2,num)) Then
                Swap r.element(p1),r.element(p2)
                For g As Integer=1 To n
                    Swap b.element(p1,g),b.element(p2,g)
                Next g
            End If
        Next p2
    Next p1
    #endmacro
    For k As Integer=1 To n-1
        pivot(k)              
        For row As Integer =k To n-1
            If b.element(row+1,k)=0 Then Exit For
            Var f=b.element(k,k)/b.element(row+1,k)
            r.element(row+1)=r.element(row+1)*f-r.element(k)
            For g As Integer=1 To n
                b.element((row+1),g)=b.element((row+1),g)*f-b.element(k,g)
            Next g
        Next row
    Next k
    'back substitute 
    For z As Integer=n To 1 Step -1
        ans.element(z)=r.element(z)/b.element(z,z)
        For j As Integer = n To z+1 Step -1
            ans.element(z)=ans.element(z)-(b.element(z,j)*ans.element(j)/b.element(z,z))
        Next j
    Next    z
    ans.row=row
    function = ans
End Function

Property matrix.inverse() As matrix
Dim As Integer n=row
static As matrix  ans:ans.row=row:ans.col=col
static As vector temp
temp.row=row
#define _reset(t) For a As Integer=1 To n:t.element(a)=0:Next
For a As Integer=1 To n
    _reset(temp)
    temp.element(a)=1
    temp=GaussJordan(temp)
    For b As Integer=1 To n
        ans.element(b,a)=temp.element(b)
    Next b
Next a
Return ans
End Property

Sub Interpolate(x_values() As Double,y_values() As Double,p() As Double)
        Var n=Ubound(x_values)
        static as matrix mat
        mat.row=n:mat.col=n
        static as vector rhs,ans
        rhs.row=n
        Redim p(0):Redim p(1 To n)
        For a As Integer=1 To n
            rhs.element(a)=y_values(a)
            For b As Integer=1 To n
                mat.element(a,b)=x_values(a)^(b-1)
            Next b
        Next a
        'Solve the linear equations
        ans=mat.GaussJordan(rhs)
        for z as integer=1 to n:p(z)=ans.element(z):next
    End Sub
    
    
'=========== SET UP A SYSTEM ======================

Dim shared As matrix m
Dim shared As vector rhs
Dim As vector solution

'======================== 
M=Type<matrix>({{1,2,3},_
               {-5,8,0},_
               {7,1,2}})',_
  m.row=3:m.col=3   'Must state number of rows/columns          
rhs=Type<vector>({-6,0,4})
rhs.row=3           'like wise, state the vector dimension  
'=========================  

solution=M.GaussJordan(rhs)
Print solution

'============ Another system  ==========================
for x as integer=1 to 5
    for y as integer=1 to 5
        read M.element(x,y)
    next y
next x
M.row=5:M.col=5 'state the dimensions
restore r
for x as integer=1 to 5
    read rhs.element(x)
next x
rhs.row=5   'state the dimension

Print M.GaussJordan(rhs)

Print "Matrix ":Print M
Print "Inverse":Print M.inverse
Print "matrix x inverse":Print (M*M.inverse)

m:
data 2,-9,7,0,0
data 0,-7,6,6,3
data 0,9,0,7,5
data 6,6,9,0,4
r:
data 9,8,7,0,0

Sleep
'==================== Interploating polynomial example ===================================================  

'Evaluate a polynomial at x
    Function polyeval(Coefficients() As Double,byval x As Double) As Double
        Dim As Double acc
        For i As Integer=Ubound(Coefficients) To Lbound(Coefficients) Step -1
            acc=acc*x+Coefficients(i)
        Next i
        Return acc
    End Function
    
    'mess around sub
    sub finish
    #define Sweep(p) For z =0 To (size):Swap p[z],p[z+1]:next
    dim as byte ptr sp=screenptr
    dim as integer size=800*600,count,z
    do:count+=1:sweep(sp):flip:loop until count=800
    end sub
'==========================================
    Screen 19,,2
    screenset 1,0
    'some x/y points
    Dim As Double x(1 To ...)={10, 50, 150,180,200,250,300,400,420,430}
    Dim As Double y(1 To ...)={300,450,400,200,100,100,300,100,50,90}
    Redim As Double p(0)
    
    'Get the polynomial p()
    Interpolate(x(),y(),p())



    print "Polynomial Coefficients:"
    For z As Integer=1 To Ubound(p)
        If z=1 Then
            Print "constant term  ";p(z)
        Else
            Print "x^";z-1;" =  ",p(z)
        End If
    Next z
    
    'plot the interpolating polynomial
    pset(0,polyeval(p(),0))
    For x As Double=0 To 800 Step 800/10000
        line -(x,polyeval(p(),x))
    Next x
    
    'Mark the x~y points
    For z As Integer=Lbound(x) To Ubound(x)
        Circle(x(z),y(z)),5,4,,,,f
    Next z
    flip
    
    Sleep


finish
    
  

[dodicat]

Oops.
the dimensions for the last matrix and vector should be 5

[albert]

Code: Select all

'abstract trig art animation #627

'Written in FreeBasic for Windows

dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/45
dim as double deg1
dim as double deg1_start =  0
dim as double deg1_end   =360
dim as double deg1_inc   =  1


dim as double rad2=atn(1)/45
dim as double deg2
dim as double deg2_start=  0
dim as double deg2_end  =360
dim as double deg2_inc  =  1

dim as double c1
dim as double c2
dim as double s1
dim as double s2

dim as double x1
dim as double y1
dim as double x2
dim as double y2

dim as double radius = 200
dim as double xctr = xres/2
dim as double yctr = yres/2

dim as single  span   = 0
dim as integer toggle = 0
dim as string ink

do
    
    screenlock
    cls

    for deg1 = 0 to 360 step 5
        
        c1=cos(deg1*rad1)
        s1=sin(deg1*rad1)
        
        x1=radius*c1 * cos(log(span^rad1))
        y1=radius*s1 * sin(log(span^rad1)*span*rad1) * tan(deg1*rad1*s1)
            
        for deg2 = 0 to 360 step .5
            
            c2 = cos(deg2*rad2)
            s2 = sin(deg2*rad2)
            
            x2=radius*c2 ^ c1 
            y2=radius*s2 ^ c1 * sin(deg2*rad2*s1^span) * sin(log(span*rad2)*s1) * sin(log(tan(deg2*rad2*s2)*rad2))
            
            pset( xctr++(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr++(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , deg1
        
            pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg1
        
        next
        
        'sleep 1
    
    next

    draw string (0,00) , "Press esc to exit."
    draw string (0,20) , "Press space to pause and single step."
    draw string (0,40) , "Span = " + str(span)
    
    screenunlock
    sleep 100
        
    'scroll back and forth thru som values to animate
    select case toggle
        case 0
            span+= .5
            if span >= +10 then toggle = 1
        case 1
            span-= .5
            if span <= +00 then toggle = 0
    end select

    ink = inkey
    
    if ink = " " then sleep
    
loop until ink = chr(27)

SLEEP
END

[integer]

Whatever happened to your multivariable chinese remainder procedure, did you complete it?

The specific problem was solved by a series of short FreeBasic routines.
The solution to the general case appeared to be a very steep climb, so I placed it aside.
In 2012 Oliver Knill published a paper (that elaborated on an earlier 2005 paper of his) which gave me the solution being sought.
Thanks for remembering.

[albert]

I redid Vari_Cyph

Vari_Cyph_FB_V6

Code: Select all

#define WIN_INCLUDEALL
#Include once "windows.bi"
#Include once "/win/commctrl.bi"
#Include once "file.bi"

Dim shared as integer TabPages    : TabPages     = 1
Dim Shared as integer GarbageBits : GarbageBits  = 64
Dim Shared as integer GarbageBytes: GarbageBytes = 1
'===============================================================================
'===============================================================================
const Keys_Spinner_Val_max = 1024
const Keys_Spinner_val_min = 8
const Keys_Spinner_val_inc = 8
dim shared as uinteger Keys_Spinner_val = 8
 
const Garbage_Spinner_Val_max = 128
const Garbage_Spinner_val_min = 1
const Garbage_Spinner_val_inc = 1
dim shared as uinteger Garbage_Spinner_val = 1 
'===============================================================================
'===============================================================================

dim shared as string file , extension , FileData

redim shared as integer Key(0 to (64*TabPages)-1)
redim shared as Ubyte SubKey(0 to 15)

Declare Sub Destroy_Tabs_n_Edits()
Declare sub Create_Tabs_n_Edits()

Declare sub LoadCypheredText()
Declare sub Cypher()
Declare sub DeCypher()

Declare sub GetKeys()
Declare sub LoadKey()
Declare sub SaveKey()
Declare sub SaveOutput()

Declare sub GenerateKey()
Declare sub GenerateSubKey()
Declare sub CopyOutputToInput()

Declare sub MessageSpinner_Up()
Declare sub MessageSpinner_Dn()
Declare sub MessageSize()
Declare sub GarbageSpinner_Up()
Declare sub GarbageSpinner_Dn()
Declare sub GarbageSize()

Declare Sub Help()

Declare sub GetFileName()

ReDim shared as hwnd STATICS(1 to TabPages)
ReDim shared as hwnd EDIT_KEY(1 to TabPages,1 to 8,1 to 8)

Dim shared As MSG msg     ' Message variable (stores massages)
Dim shared As HWND hWnd _
                   , EDIT_IN _
                   , TABS _
                   , STATIC_OUTS(0 to 15) _
                   , EDIT_OUTS(0 to 15) _
                   , EDIT_OUT _
                   , LOADCYPHTEXT_BTN _
                   , CYPHER_BTN _
                   , DECYPHER_BTN _
                   , LOADKEY_BTN _
                   , SAVEKEY_BTN _
                   , GENERATEKEY_BTN _
                   , SPINNER_MESSAGE_UP _
                   , SPINNER_MESSAGE_DN _
                   , MESSAGE_SIZE _
                   , SPINNER_GARBAGE_UP _
                   , SPINNER_GARBAGE_DN _
                   , GARBAGE_SIZE _
                   , GENERATESUBKEY_BTN _
                   , SAVEOUTPUT_BTN _
                   , COPY_OUTPUT_TO_INPUT 'for multiple cyphering.
'===============================================================================                   
' Create window
hWnd = CreateWindowEx( 0, "#32770", "Vari_Cyph_FB_V6 Feb/2014", WS_OVERLAPPEDWINDOW Or WS_VISIBLE, 100, 100, 600, 600, 0, 0, 0, 0 )

'create in edit
EDIT_IN  = CreateWindowEx( 0, "EDIT", "", WS_VISIBLE Or WS_CHILD Or WS_BORDER or ES_MULTILINE or WS_VSCROLL or WS_HSCROLL               , 10, 10,430,110, hWnd, 0, 0, 0 )
'create readonly edit out
EDIT_OUT = CreateWindowEx( 0, "EDIT", "", WS_VISIBLE Or WS_CHILD Or WS_BORDER or ES_MULTILINE or WS_VSCROLL or WS_HSCROLL or ES_READONLY, 10,430,430,130, hWnd, 0, 0, 0 )

'create labels and edits for output.
dim as integer count1
for y as integer = 1 to 2 step 1
    for x as integer = 1 to 8 step 1
       count1 = ((y*8)-8)+x-1
       SubKey(count1)=(65+count1)
       STATIC_OUTS(count1) = CreateWindowEx( 0,"STATIC", right("0000" + bin(count1),4), WS_VISIBLE Or WS_CHILD             ,(x*38)-38+(15*x) ,280+( (y*12)+20+(32*y)) , 38, 20, hWnd, 0, 0, 0 )
       EDIT_OUTS( count1 ) = CreateWindowEx( 0,"EDIT"  , CHR(SubKey(count1))          , WS_VISIBLE Or WS_CHILD Or WS_BORDER,(x*38)-30+(15*x) ,305+( (y*12)+10+(32*y)) , 18, 20, hWnd, 0, 0, 0 )
   next
next

Redim key(0)
Redim SubKey(0)

LOADCYPHTEXT_BTN  = CreateWindowEx( 0,"BUTTON"  , "Load Cypher"  , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,10 , 100, 25, hWnd, 0, 0, 0 )
CYPHER_BTN        = CreateWindowEx( 0,"BUTTON"  , "Cypher"       , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,50 , 100, 25, hWnd, 0, 0, 0 )
DECYPHER_BTN      = CreateWindowEx( 0,"BUTTON"  , "DeCypher"     , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,90 , 100, 25, hWnd, 0, 0, 0 )

LOADKEY_BTN       = CreateWindowEx( 0,"BUTTON"  , "Load Key"     , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,150 , 100, 25, hWnd, 0, 0, 0 )
SAVEKEY_BTN       = CreateWindowEx( 0,"BUTTON"  , "Save Key"     , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,190 , 100, 25, hWnd, 0, 0, 0 )
GENERATEKEY_BTN   = CreateWindowEx( 0,"BUTTON"  , "Generate Key" , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,230 , 100, 25, hWnd, 0, 0, 0 )
GENERATESUBKEY_BTN= CreateWindowEx( 0,"BUTTON" ,"Generate SubKey", WS_VISIBLE Or WS_CHILD Or WS_BORDER,445 ,400 , 130, 25, hWnd, 0, 0, 0 )
SAVEOUTPUT_BTN    = CreateWindowEx( 0,"BUTTON" ,  "Save Output"  , WS_VISIBLE Or WS_CHILD Or WS_BORDER,445 ,450 , 130, 25, hWnd, 0, 0, 0 )
COPY_OUTPUT_TO_INPUT = CreateWindowEx( 0,"BUTTON" ,  "Copy to Input", WS_VISIBLE Or WS_CHILD Or WS_BORDER,445 ,500 , 130, 25, hWnd, 0, 0, 0 )

SPINNER_MESSAGE_UP   = CreateWindowEx( 0,"BUTTON"  , ""             , WS_VISIBLE Or WS_CHILD Or WS_BORDER,543 ,270 ,  35, 12, hWnd, 0, 0, 0 )
SPINNER_MESSAGE_DN   = CreateWindowEx( 0,"BUTTON"  , ""             , WS_VISIBLE Or WS_CHILD Or WS_BORDER,543 ,282 ,  35, 12, hWnd, 0, 0, 0 )
MESSAGE_SIZE         = CreateWindowEx( 0,"EDIT"    , str(TabPages*8)      , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,270 ,  80, 25, hWnd, 0, 0, 0 )
SPINNER_GARBAGE_UP   = CreateWindowEx( 0,"BUTTON"  , ""             , WS_VISIBLE Or WS_CHILD Or WS_BORDER,543 ,300 ,  35, 12, hWnd, 0, 0, 0 )
SPINNER_GARBAGE_DN   = CreateWindowEx( 0,"BUTTON"  , ""             , WS_VISIBLE Or WS_CHILD Or WS_BORDER,543 ,312 ,  35, 12, hWnd, 0, 0, 0 )
GARBAGE_SIZE         = CreateWindowEx( 0,"EDIT"    , str(GarbageBytes)   , WS_VISIBLE Or WS_CHILD Or WS_BORDER,460 ,300 ,  80, 25, hWnd, 0, 0, 0 )
'End Control setup

Create_Tabs_n_Edits()

'===============================================================================
'===============================================================================
'begin mesage processing
While GetMessage( @msg, 0, 0, 0 )
    
    TranslateMessage( @msg )
    DispatchMessage( @msg )
  
    Select Case msg.hwnd
        Case hWnd
            Select Case msg.message
                Case 273
                Destroy_Tabs_n_Edits()
                PostQuitMessage(0)
                'End
            End Select
            
        Case TABS        ' If msg is window hwnd: get messages from window
            Select Case msg.message
                case WM_LBUTTONDOWN
                    count1 = TabCtrl_GetCurSel(TABS)+1
                    for a as integer = lbound(STATICS) to ubound(STATICS)
                        ShowWindow(STATICS(a), SW_HIDE)
                    next
                    ShowWindow(STATICS(count1), SW_SHOW)
            End Select

        Case LOADCYPHTEXT_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    LoadCypheredText()
            End Select
        
        Case CYPHER_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    Cypher()
            End Select
        
        Case DECYPHER_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    DeCypher()
            End Select
        
        Case LOADKEY_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    LoadKey()
            End Select
        
        Case SAVEKEY_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    SaveKey()
            End Select
        
        case SPINNER_MESSAGE_UP
            select case msg.message
                case WM_LBUTTONDOWN
                    MessageSpinner_Up()
            end select

        case SPINNER_MESSAGE_DN
            select case msg.message
                case WM_LBUTTONDOWN
                    MessageSpinner_Dn()
            end select
        
        Case MESSAGE_SIZE
            select case msg.message
                case WM_LBUTTONDOWN
                    MessageSize()
            end select
            
        Case SPINNER_GARBAGE_UP
            select case msg.message
                case WM_LBUTTONDOWN
                    GarbageSpinner_Up()
            end select
        
        Case SPINNER_GARBAGE_DN
            select case msg.message
                case WM_LBUTTONDOWN
                    GarbageSpinner_Dn()
            end select
            
        Case GARBAGE_SIZE
            select case msg.message
                case WM_LBUTTONDOWN
                    GarbageSize()
            end select
        
        Case SAVEOUTPUT_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    SaveOutput()
            End Select
        
        Case COPY_OUTPUT_TO_INPUT
            select Case msg.message
                case WM_LBUTTONDOWN
                    CopyOutputToInput()
            end select
        
        Case GENERATEKEY_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    GenerateKey()
            End Select
        
        Case GENERATESUBKEY_BTN
            Select Case msg.message
                case WM_LBUTTONDOWN
                    GenerateSubKey()
            End Select
    
    End Select

Wend
Destroy_Tabs_n_Edits()
PostQuitMessage(0)
END
'===============================================================================
'===============================================================================
'subs and functions below here
'===============================================================================
'===============================================================================
sub MessageSpinner_Up()
    Destroy_Tabs_n_Edits()
    if Keys_Spinner_val < Keys_Spinner_val_max then Keys_Spinner_val+= Keys_Spinner_val_inc
    SetWindowText(MESSAGE_SIZE,str(Keys_Spinner_val))
    TabPages = Keys_Spinner_val / 8
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    Create_Tabs_n_Edits()
end sub
'===============================================================================
'===============================================================================
sub MessageSpinner_Dn()
    Destroy_Tabs_n_Edits()
    if Keys_Spinner_val > Keys_Spinner_val_min then Keys_Spinner_val-= Keys_Spinner_val_inc
    SetWindowText(MESSAGE_SIZE,str(Keys_Spinner_val))
    TabPages = Keys_Spinner_val / 8
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    Create_Tabs_n_Edits()
end sub
'===============================================================================
'===============================================================================
sub MessageSize()
    Destroy_Tabs_n_Edits()
    dim as string*6 textin
    GetWindowText(MESSAGE_SIZE,textin,5)
    textin=trim(textin,chr(32))
    textin=trim(textin,chr(0))
    Keys_Spinner_val = val(textin)
    if Keys_Spinner_val > Keys_Spinner_Val_max = 1024 then 
        Keys_Spinner_val = Keys_Spinner_val_max
    end if
    dim as string str1
    dim as integer dec1
    do
        str1=str(Keys_Spinner_val/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then Keys_Spinner_val+=1
    loop until dec1 = 0
    SetWindowText(MESSAGE_SIZE,str(Keys_Spinner_val))
    TabPages = Keys_Spinner_val / 8
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    Create_Tabs_n_Edits()
end sub
'===============================================================================
'===============================================================================
sub GarbageSpinner_Up()
    if Garbage_Spinner_val < Garbage_Spinner_val_max then Garbage_Spinner_val+= Garbage_Spinner_val_inc
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    SetWindowText(GARBAGE_SIZE,str(Garbage_Spinner_val))
end sub
'===============================================================================
'===============================================================================
sub GarbageSpinner_Dn()
    if Garbage_Spinner_val > Garbage_Spinner_val_min then Garbage_Spinner_val-= Garbage_Spinner_val_inc
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    SetWindowText(GARBAGE_SIZE,str(Garbage_Spinner_val))
End Sub
'===============================================================================
'===============================================================================
sub GarbageSize()
    Destroy_Tabs_n_Edits()
    dim as string*6 textin
    GetWindowText(GARBAGE_SIZE,textin,5)
    textin=trim(textin,chr(32))
    textin=trim(textin,chr(0))
    Garbage_Spinner_val = val(textin)
    if Garbage_Spinner_val > Garbage_Spinner_val_max then 
        Garbage_Spinner_val = Garbage_Spinner_val_max
    end if
    SetWindowText(GARBAGE_SIZE,str(Garbage_Spinner_val))
    TabPages = Keys_Spinner_val / 8
    Garbagebits = Garbage_Spinner_Val*8*Keys_Spinner_Val
    GarbageBytes = GarbageBits/8/Keys_Spinner_val
    Create_Tabs_n_Edits()
end sub
'===============================================================================
'===============================================================================
Sub Destroy_Tabs_n_Edits()
    'delete Statics and edits
    for a as integer = 1 to ubound(EDIT_KEY,1)
        for x as integer = 1 to ubound(EDIT_KEY,2)
            for y as integer = 1 to ubound(EDIT_KEY,3)
                DestroyWindow(EDIT_KEY(a,x,y))
            next
        next
        DestroyWindow(STATICS(a))
        TabCtrl_DeleteItem(TABS,a)
    next
    DestroyWindow(TABS)
end Sub
'===============================================================================
'===============================================================================
sub Create_Tabs_n_Edits()
    'create tab ctrl
    TABS = CreateWindowEX( 0, WC_TABCONTROL , "", WS_VISIBLE or WS_CHILD Or WS_CLIPSIBLINGS, 10, 120 , 420, 220, hWnd, 0, 0, 0 )
    'create tab flaps and text on tab flaps
    Dim As Integer Count1
    Dim As String*256 text
    for a as integer = 1 to TabPages
        count1=(a*64)-63
        text = Str(count1) + " to " + str(count1+63)
        Dim As  TCITEM tie
        tie.mask = TCIF_TEXT 
        tie.pszText = StrPtr(text)
        TabCtrl_InsertItem(TABS, count1 ,@tie  )
    next
    TabCtrl_SetCurSel(TABS,TabPages-1)
    
    'put static boxes on the tabs and create x,y grid of edits on them
    ReDim preserve STATICS(1 to TabPages)
    ReDim preserve EDIT_KEY(1 to TabPages,1 to 8,1 to 8)
    redim key(0 to TabPages*64-1)
    for a as integer = 1 to TabPages
        STATICS(a) = CreateWindowEX( 0 , "STATIC" , "", WS_CHILD or WS_BORDER or WS_CLIPSIBLINGS, 8, 30 , 405, 185, TABS , 0, 0, 0 )
        for x as integer = 1 to 8
            for y as integer = 1 to 8
                count1 = ((a*64)-64)+((x*8)-8)+y-1
                Key(count1) = count1+1
                EDIT_KEY(a,x,y) = CreateWindowEx( 0 ,"EDIT", str(Key(count1)) , WS_VISIBLE or WS_CHILD Or WS_BORDER , (x*40)-47+(11*x) , (y*12)-17+(10*y) , 38, 20, STATICS(a),  0, 0, 0 )
            next
        next
    next
    TabCtrl_SetCurSel(TABS,TabPages-1)
    for a as integer = lbound(STATICS) to ubound(STATICS)
        ShowWindow(STATICS(a), SW_HIDE)
    next
    ShowWindow(STATICS(TabPages), SW_SHOW)
    redim Key(0)
end sub
'===============================================================================
'===============================================================================
sub LoadCypheredText()
    
    GetFileName()
    FileData=""
    
    if fileexists(file) then 
        
        dim as ulongint position
        dim as ulongint length = filelen(file)-2
        dim as ubyte char
        
        open file for binary as #1
            
            position=0
            do
                Get #1,,Char
                FileData+=chr(char)
                position+=1
            loop until position=length
        
        close #1
        
        SetWindowText(EDIT_IN,FileData)
        
        FileData=""
        file=""
    end if
    
end sub

'===============================================================================
'===============================================================================
sub Cypher()
    
    Redim Key(0 to (64*TabPages-1))
    Redim SubKey(0 to 15)
    
    GetKeys()
    
    'get message input from input edit_box into a string
    dim as string GetInputMessage
    dim as integer txtlen
    txtlen = (GetWindowTextLength(EDIT_IN)+1)
    GetInputMessage = string(txtlen,chr(0))
    GetWindowText(EDIT_IN , GetInputMessage, txtlen)
    GetInputMessage = trim(GetInputMessage,Chr(32))
    GetInputMessage = trim(GetInputMessage,chr(0))
    
    'make input string an even number of Block sizes
    dim as string str1
    dim as double dec
    do
        str1=str( len(GetInputMessage) / (TabPages*8) )
        dec=instr(1,str1,".")
        if dec<>0 then GetInputMessage+="_" 'if message is not a multiple of (TabPages*8) characters
    loop until dec=0
    
    'turn message into binary
    dim as string BinaryMessageBlocks
    for a as integer = 1 to len(GetInputMessage) step 1
        BinaryMessageBlocks+= right("00000000" + bin( asc(mid(GetInputMessage,a,1)) ) ,8)
    next    
    
    'stick user message bits (TabPages*64/TabPages) into random garbage of length GarbageBits
    dim as string MessageBits
    dim as string RandomGarbage
    dim as string Accumulated
    for a as integer = 1 to len(BinaryMessageBlocks) step (64*TabPages)
        
        MessageBits = mid(BinaryMessageBlocks,a, 64*tabPages)
        
        RandomGarbage=""
        for garbage as integer = 1 to GarbageBits step 1 
            RandomGarbage+=str( int(rnd*2) ) 'right("00000000" + bin(int(rnd*26)+97) , 8)
        next
        
        for insert as integer = lbound(Key) to ubound(Key)
            mid(RandomGarbage,Key(insert),1) = mid(MessageBits,insert+1,1)
        next
        Accumulated+=RandomGarbage
    next
    
    
    Redim Key(0)
    
    dim as string CypheredOutput
    dim as string*4 QuadBits
    for a as integer = 1 to len(Accumulated) step 4
        dec=0
        QuadBits=mid(Accumulated,a,4)
        mid(Accumulated,a,4)="0000"
        
        if mid(QuadBits,1,1)="1" then Dec+=8
        if mid(QuadBits,2,1)="1" then Dec+=4
        if mid(QuadBits,3,1)="1" then Dec+=2
        if mid(QuadBits,4,1)="1" then Dec+=1
        
        CypheredOutput+=Chr(SubKey(Dec))
    next
    
    Redim SubKey(0)
    
    SetWindowText(EDIT_OUT,CypheredOutput)
    CypheredOutput=""
    
end sub
'===============================================================================
'===============================================================================
sub DeCypher()
    
    redim Key(0 to ((TabPages*64)-1))
    redim SubKey(0 to 15)
    
    GetKeys()
    
    'get message input from input edit_box into a string
    dim as string GetInputMessage
    dim as integer txtlen
    txtlen = (GetWindowTextLength(EDIT_IN)+1)
    GetInputMessage = string(txtlen,chr(0))
    GetWindowText(EDIT_IN , GetInputMessage, txtlen)
    GetInputMessage = trim(GetInputMessage,chr(0))
    
    if len(GetInputMessage)<>0 then
        
        dim as string BinarySubOutput(1 to (len(GetInputMessage)/(GarbageBits/8)/2) )
        dim as string Bites
        dim as integer Chunks = (len(GetInputMessage)/(GarbageBits/8)/2)
        dim as ubyte Char
        Dim as integer Dec=1
        for a as integer = 1 to len(GetInputMessage) step (len(GetInputMessage)/Chunks)
            Bites = mid( GetInputMessage, a, len(GetInputMessage)/Chunks )
            for b as integer = 1 to len(bites) 
                Char = asc( mid(Bites,b,1) )
                for c as integer = 0 to 15
                    if Char = SubKey(c) then BinarySubOutput(Dec)+=right("0000"+bin(c),4)
                next
            next
            Dec+=1
        next
        
        Dec-=1
        dim as string Binary_out
        for a as integer = 1 to Dec step 1
            for b as integer = 0 to ubound(Key)
                Binary_Out+= mid(BinarySubOutput(a),Key(b),1)
            next
        next
        
        dim as string FinalOutput
        dim as string*8 OctaBits
        for a as integer = 1 to len(Binary_Out) step 8
            OctaBits = mid(Binary_Out,a,8)
            mid(Binary_Out,a,8)="00000000"
            Dec=0
            if mid(OctaBits,1,1)="1" then Dec+=128
            if mid(OctaBits,2,1)="1" then Dec+= 64
            if mid(OctaBits,3,1)="1" then Dec+= 32
            if mid(OctaBits,4,1)="1" then Dec+= 16
            if mid(OctaBits,5,1)="1" then Dec+=  8
            if mid(OctaBits,6,1)="1" then Dec+=  4
            if mid(OctaBits,7,1)="1" then Dec+=  2
            if mid(OctaBits,8,1)="1" then Dec+=  1
        
            FinalOutput+=Chr(Dec)
        next
        
        SetWindowText(EDIT_OUT,FinalOutput)
        
    end if
    
end sub

'===============================================================================
'===============================================================================
sub GetKeys()
    
    'get Keys from Edits
    dim as string*16 CharKey
    dim as string*1 CharSubKey
    
    for a as integer = 1 to TabPages
        for b as integer = 1 to 8
            for c as integer = 1 to 8
                GetWindowText( EDIT_KEY(a,b,c), CharKey , 16) 'GarbageBytes+1 )  
                key( ((a*64)-64)+((b*8)-8)+c-1 ) = val(CharKey)
            next
        next
    next
    for a as integer = 1 to 2
        for b as integer = 1 to 8
            'print ((a*8)-8) +b-1
            GetWindowText( EDIT_OUTS( ((a*8)-8)+b-1 ) , CharSubKey , 2)
            SubKey( ((a*8)-8)+b-1 ) = asc(CharSubKey)
        next
    next
    
end sub

'===============================================================================
'===============================================================================
sub LoadKey()
    
    Redim Key(0 to ((TabPages*64)-1))
    Redim SubKey(0 to 15)
        
    GetFileName()
    
    if fileexists(file) then
        
        open file for input as #1
            
            dim as String Inputs
            
            line input #1 , Inputs
            if val(Inputs) <> ubound(Key) then
                BEEP
                print "!!~~WRONG SIZE KEY~~!!"
                return
            end if
            
            line input #1 , Inputs
            if val(Inputs) <> GarbageBytes then
                BEEP
                print "!!~~WRONG SIZE KEY~~!!"
                return
            end if
                
            dim as ulongint count
            
            count=0
            do
                line input #1 , Inputs
                Key(count) = val(Inputs)
                count+=1
            loop until count = ubound(Key)+1
            
            count=0
            do
                line input #1 , Inputs
                SubKey(count) = val(Inputs)
                count+=1
            loop until count = ubound(SubKey)+1
        
        Close #1
        
        dim as ulongint dec
        for a as integer =1 to TabPages
            for x as integer = 1 to 8
                for y as integer = 1 to 8
                    dec = (((a*64)-64)+((x*8)-8)+y)-1
                    'print a,x,y, Dec ;" ";Key(Dec)
                    SetWindowText( EDIT_KEY(a,x,y) , str(Key(dec)) )
                next
            next
        next
        for y as integer = 1 to 2 step 1
            for x as integer = 1 to 8 step 1
                Dec = (((y*8)-8)+x)-1
                'print y,x,Dec,SubKey(Dec)
                SetWindowText(EDIT_OUTS( Dec ) , chr(SubKey(Dec)) )
            next
        next
            
        Redim Key(0)
        Redim SubKey(0)
            
        file=""
        extension=""

    end if
    
end sub
'===============================================================================
'===============================================================================
sub SaveKey()
    
    Redim Key( 0 to ((TabPages*64)-1) )
    Redim SubKey(0 to 15)
        
    GetKeys()
    GetFileName()
    
    dim as string SaveKeys = ""
    
    if file<>"" then
    
        open file for output as #1
            
            print #1 , ltrim(str(ubound(key)))
            print #1 , ltrim(str(GarbageBytes))
            
            for a as integer = 0 to ((TabPages*64)-1)
                print #1 , str(Key(a))
            next
        
            for a as integer = 0 to 15
                Print #1 , SubKey(a)
            next
        
        close #1
    
    end if
    
    Redim Key(0)
    Redim SubKey(0)
    
end sub
'===============================================================================
'===============================================================================
sub SaveOutput()
    
    GetFileName()
    if file<>"" then 
        
        'get message input from Output edit_box into a string
        dim as string GetOutputMessage
        dim as integer txtlen
        txtlen = (GetWindowTextLength(EDIT_OUT)+1)
        GetOutputMessage = string(txtlen,chr(0))
        GetWindowText(EDIT_OUT , GetOutputMessage, txtlen)
        GetOutputMessage = trim(GetOutputMessage,chr(0))

        open file for output as #1
        
            print #1 , GetOutputMessage
        
        close #1
    
    end if
    
end sub
'===============================================================================
'===============================================================================
Sub CopyOutputToInput()
        'get message input from Output edit_box into a string
        dim as string GetOutputMessage
        dim as integer txtlen
        txtlen = (GetWindowTextLength(EDIT_OUT)+1)
        GetOutputMessage = string(txtlen,chr(0))
        GetWindowText(EDIT_OUT , GetOutputMessage, txtlen)
        GetOutputMessage = trim(GetOutputMessage,chr(0))
        SetWindowText(EDIT_IN , GetOutputMessage)
        SetWindowText(EDIT_OUT , "")
end sub
'===============================================================================
'===============================================================================
sub GenerateKey()
    ' ((a*64)-64)+((x*8)-8)+y
    Redim Key(0 to (TabPages*64-1) )
        
    dim a as integer
    dim b as integer
    dim c as integer
    dim d as integer
  
    'create random key for main cypher.
    for a = 0 to (TabPages*64)-1
        key(a) = 0
    next
      
    a=0
    do
        b = int(rnd*GarbageBits)+1
        do
            b = int(rnd*GarbageBits)+1
            d = 0
            for c = 0 to a
               if key(c) = b then d = 1 
            next
        loop until d = 0
        key(a) = b
        a = a + 1      
    loop until a=(TabPages*64)      

    for a = 1 to TabPages
        for b=1 to 8
            for c=1 to 8
                SetWindowText( EDIT_KEY(a,b,c) , str( key( ((a*64)-64)+((b*8)-8)+c -1 )) )
            next
        next
    next
    Redim Key(0)
        
end sub
'===============================================================================
'===============================================================================
sub GenerateSubKey()
      
    Redim SubKey(0 to 15)
    'create 16 letter subsitution for output
    dim a as integer
    dim b as integer
    dim c as integer
    dim d as integer
      
    for a = 0 to 15
        SubKey(a) = 0
    next
    a=0
    do
        b = int( rnd*26 )+65
        do
            b = int( rnd*26 )+65
            d = 0
            for c=0 to a
                if SubKey(c) = b then d = 1 
            next
        loop  until d = 0
        SubKey(a) = b
        a=a+1      
    loop until a=16      
      
    'answer = ((a*8)-8) +b
    for a = 1 to 2
        for b = 1 to 8
            'print ((a*8)-8) +b-1
            SetWindowText( EDIT_OUTS( ((a*8)-8)+b-1 ) , chr( SubKey( ((a*8)-8)+b-1 ) ) )
        next
    next
    Redim SubKey(0)

end sub

'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
        
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                .lpstrTitle             = @"File To Open."
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
        
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            extension=""
            return
        else
            file = filename
            extension = right$(filename,4)
        end if

end sub

Its real slow and says "Not Responding" for several minutes at higher levels , max 1024 on the message bytes and max 128x on the garbage bytes.
If you type the values in to the edits you need to click on them after to get them to set..

Its a message scrambler , your message bits get scrambled among several times as many garbage bits.
each column of the tab grids is a character of your message and the number in the vertical edit is what bit position your message bit gets inserted into the garbage block...

[dodicat]

Hi Albert.
Tested out your Var1_Cyph, works ok with keyboard input and file load.
Although I didn't try with a very large file yet.

Here's a little rocking wave morpher:

Code: Select all

Sub Thing(w As Integer=700,_
          h As Integer=600,_
          posx As Integer=400,_
          posy As Integer=300,_
          morph as single=24,_
          aspect as single=3,_
          grade as single=6,_
          col as uinteger=rgba(255,255,255,0))
          
    Dim As Single XStep = 1
    Dim As Single YStep = 1
    Dim As Single b=w*w
    Dim As Single y,m,n
    For x As Single = 0 To w Step XStep
        dim as single s=x*x
        dim as single p=Sqr(b-s)
        For i As Single = -P To P Step grade*YStep
           dim as single r = Sqr(s+i*i)/w
           dim as single Q = (R - 1) * Sin(morph*r)
                  y=i/aspect+q*h
            If i = -p Then m=y:n=y
            If y > m Then m = y
            If y < n Then n = y
            If m=y Orelse n=y Then
                Pset(x/2+posx,-Y/2+posy),col/i 
                Pset(-x/2+posx,-Y/2+posy),col/i
            End If
        Next
    Next
End Sub
'===========================================================
Screen 19,32,2
color,rgb(0,0,50)
screenset 1,0
Dim As single Morph=0,k=1
dim as single aspect,counter,pi2=8*atn(1)

Do
counter+=.1
if counter>=pi2 then counter=0
aspect=3+sin(counter)
    Morph+=.1*k
    If Morph>35 Then k=-k
    If Morph<-35 Then k=-k
    Cls
    Thing(800,500,400,300,Morph,aspect) 
    flip
    Sleep 1,1
Loop Until Len(Inkey)
Sleep
 

[albert]

Dodicat

Cool Doodle!!!

[dodicat]

Thanks Albert.

There's been much stuff about printing text to a graphics screen in the past.
Here's a way to print a block of text and to print it all over again further along the screen.

(Had to load Bigint plus to get biggish numbers from a Pascal triangle)

Code: Select all

Dim Shared As Ubyte ADDQmod(0 To 19),ADDbool(0 To 19) 
For z As Integer=0 To 19
    ADDQmod(z)=(z Mod 10+48)
    ADDbool(z)=(-(10<=z))
Next z 

Function plusINT(_num1 As String,_num2 As String) As String
    Var _flag=0,n_=0
    Dim As Ubyte addup=Any,addcarry=Any
    #macro finish()
    answer=Ltrim(answer,"0")
    If answer="" Then answer="0"
    If _flag=1 Then Swap _num2,_num1
    Return answer
    #endmacro
    If Len(_num2)>Len(_num1) Then 
        Swap _num2,_num1
        _flag=1
    End If
    Var diff=Len(_num1)-Len(_num2)
    Var answer="0"+_num1
    addcarry=0
    For n_=Len(_num1)-1 To diff Step -1 
        addup=_num2[n_-diff]+_num1[n_]-96
        answer[n_+1]=ADDQmod(addup+addcarry)
        addcarry=ADDbool(addup+addcarry)
    Next n_ 
    If addcarry=0 Then 
        finish()
    End If
    If n_=-1 Then 
        answer[0]=addcarry+48
        finish()
    End If
    For n_=n_ To 0 Step -1 
        addup=_num1[n_]-48
        answer[n_+1]=ADDQmod(addup+addcarry)
        addcarry=ADDbool(addup+addcarry)
        If addcarry=0 Then Exit For
    Next n_
    answer[0]=addcarry+48
    finish()
End Function

Function PascalTriangleRow(RowNumber As Integer) As String
    Dim As String s,values(RowNumber)
    values(1)="1"
    For row As Integer = 2 To RowNumber
        s=""
        For i As Integer = row To 1 Step -1
            values(i) = Plusint(values(i),values(i-1))
            's+=(values(i))+","
            s+=values(i)+Chr(10)
        Next i
    Next row
    Return s
End Function

#macro ShiftRight(p,d)
Screenlock
For z As Integer=(size) To 0 Step -1
    If z+d>0 Andalso z+d<size Then
        Swap p[z],p[z+d]
    End If
Next z
Screenunlock
#endmacro

#macro ShiftLeft(p,d)
Screenlock
For z As Integer=0 To (size)
    If z+d>0 Andalso z+d<size Then
        Swap p[z],p[z+d]
    End If
Next z
Screenunlock
#endmacro
'========================================
Dim As Integer xres,yres
Screenres 1024,768
Screeninfo xres,yres
Dim As Ubyte Ptr p=Screenptr
Dim As Integer size=xres*yres
Dim As String PSC=PascalTriangleRow(94)
Print PSC
ShiftRight(p,xres/2)
Locate 1,1
Print PSC
Sleep
Dim As Integer counter
Do
    counter+=1
    ShiftLeft(p,1)
Loop Until counter>xres/2
Locate 5,15
Print "Done"
Sleep
 

[albert]

Code: Select all

'abstract trig art animation #628

'Written in FreeBasic for Windows

dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/45
dim as double deg1
dim as double deg1_start =  0
dim as double deg1_end   =360
dim as double deg1_inc   =  1


dim as double rad2=atn(1)/45
dim as double deg2
dim as double deg2_start=  0
dim as double deg2_end  =360
dim as double deg2_inc  =  1

dim as double c1
dim as double c2
dim as double s1
dim as double s2

dim as double x1
dim as double y1
dim as double x2
dim as double y2

dim as double radius = 200
dim as double xctr = xres/2
dim as double yctr = yres/2

dim as single  span   = 0
dim as integer toggle = 0
dim as string ink

do
    
    screenlock
    cls

    for deg1 = 0 to 360 step 5
        
        c1=cos(deg1*rad1)
        s1=sin(deg1*rad1)
        
        x1=radius*c1 * cos(log(span^rad1))
        y1=radius*s1 * sin(log(span^rad1))
            
        for deg2 = 0 to 360 step .5
            
            c2 = cos(deg2*rad2)
            s2 = sin(deg2*rad2)
            
            x2=radius*c2 ^ 5 ^ c1 * cos(deg2*rad2*c1^span) * cos(log(span*rad2)*c1) * cos(log(tan(deg2*rad2*c2)*rad2))
            y2=radius*s2 ^ 3 ^ c1 * cos(deg2*rad2*s1^span) * sin(log(span*rad2)*s1) * sin(log(tan(deg2*rad2*s2)*rad2))
            
            pset( xctr++(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr++(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , deg1
        
            pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg1
        
        next
        
        'sleep 1
    
    next

    draw string (0,00) , "Press esc to exit."
    draw string (0,20) , "Press space to pause and single step."
    draw string (0,40) , "Span = " + str(span)
    
    screenunlock
    sleep 100
        
    'scroll back and forth thru som values to animate
    select case toggle
        case 0
            span+= .5
            if span >= +10 then toggle = 1
        case 1
            span-= .5
            if span <= +00 then toggle = 0
    end select

    ink = inkey
    
    if ink = " " then sleep
    
loop until ink = chr(27)

SLEEP
END

Code: Select all

'abstract trig art animation #629

'Written in FreeBasic for Windows

dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/90
dim as double deg1
dim as double deg1_start =  0
dim as double deg1_end   =360
dim as double deg1_inc   =  1


dim as double rad2=atn(1)/45
dim as double deg2
dim as double deg2_start=  0
dim as double deg2_end  =360
dim as double deg2_inc  =  1

dim as double c1
dim as double c2
dim as double s1
dim as double s2

dim as double x1
dim as double y1
dim as double x2
dim as double y2

dim as double radius = 200
dim as double xctr = xres/2
dim as double yctr = yres/2

dim as single  span   = 0
dim as integer toggle = 0
dim as string ink

do
    
    screenlock
    cls

    for deg1 = 0 to 360 step 4
        
        c1=cos(deg1*rad1)
        s1=sin(deg1*rad1)
        
        x1=radius*c1 * cos(log(span^rad1))
        y1=radius*s1 * sin(log(span^rad1))
            
        for deg2 = 0 to 360 step .5
            
            c2 = cos(deg2*rad2)
            s2 = sin(deg2*rad2)
            
            x2=radius*c2 ^ 5 ^ c1 * cos(deg2*rad2*c1^span) * cos(log(span*rad2)*c1) * cos(log(tan(deg2*rad2*c2)*rad2))
            y2=radius*s2 ^ 3 ^ c1 * cos(deg2*rad2*s1^span) * sin(log(span*rad2)*s1) * sin(log(tan(deg2*rad2*s2)*rad2))
            
            pset( xctr++(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , deg1
            pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg1
        
            pset( xctr++(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , deg1
        
            pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , deg1
            pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg1
        
        next
        
        'sleep 1
    
    next

    draw string (0,00) , "Press esc to exit."
    draw string (0,20) , "Press space to pause and single step."
    draw string (0,40) , "Span = " + str(span)
    
    screenunlock
    sleep 100
        
    'scroll back and forth thru som values to animate
    select case toggle
        case 0
            span+= 1.33
            if span >= +10 then toggle = 1
        case 1
            span-= 1.33
            if span <= +00 then toggle = 0
    end select

    ink = inkey
    
    if ink = " " then sleep
    
loop until ink = chr(27)

SLEEP
END

[dodicat]

Thanks Albert.
Squares is quiet these days.
Here is one of my old Bitmap resizers.
Unfortunately fb 0.9 doesn't allow a proper window for this, so I have to use no-frame.

This means that I had to make up a sub to move the window in order to see the console upon which is written the new bitmap dimensions.
(If I had a proper window I could write them as a windowtitle)
It's a bit rough round the edges as it stands, but to resize you must use the right and bottom margins AND the screen must be at the top left corner of your monitor.
If the screen is not at the top left then right click it so set it there.
(I omitted the bsave bit, so it's just a preview)

Code: Select all

Dim  As String picture="parrot.bmp"
#include "crt.bi"

Type v2
    As Integer x,y
    col As Uinteger
    As Ushort Bits
End Type

Function Size(bmp As String) As V2 'get bitmap width/height/ colour resolution 
    Dim As V2 b
    Open bmp For Binary Access Read As #1
    Get #1, 19, b.X
    Get #1, 23, b.Y
    Get #1, 29, b.Bits
    Close #1
    Return b
End Function
Sub moveall
    Dim As Integer mx,my,mb,x,y,dx,dy
    Static As Integer lastmx,lastmy
    Getmouse mx,my,,mb
    Screencontrol 0, x, y
    Static As Integer pressed,moved
    If mb=1 Then pressed=-1
    If mb=0 Then pressed=0
    If lastmx<>mx Or lastmy<>my Then moved=-1 Else moved=0
    If moved Then dx=lastmx-mx:dy=lastmy-my
    If pressed And moved Then
        Screencontrol 100, x-dx, y - dy 
        pressed=0
        Exit Sub
    End If
    lastmx=mx:lastmy=my
End Sub


Declare Function MoveWindow Alias "MoveWindow"(As Any Ptr,As Integer,As Integer,As Integer,As Integer,As Integer) As Integer
Dim As Integer DesktopW,DesktopH
Dim As Integer monitorW,monitorH
Screeninfo monitorW,monitorH
monitorH-=30'to keep clear of taskbar
Dim As V2 Sz=size(picture)
DesktopW=Sz.x
DesktopH=Sz.y
Dim As Integer xres,yres
Screenres DesktopW,DesktopH,32,,&h08
Bload picture
Screeninfo xres,yres

Dim As Integer I
Screencontrol(2,I)'getwindowhandle
Dim As Any Ptr Win = Cast(Any Ptr,I)


Dim As Integer blow=(DesktopW-xres)
Dim As Integer Newxres=xres+blow
Dim As Integer Newyres=(yres+blow*yres/xres)

MoveWindow(Win,0,0,Newxres,Newyres,1)

Dim As Integer mx,my,mb,lastmx,lastmy
Dim As Integer maxX=Newxres,MaxY=Newyres
Dim As Integer diffX,diffY,xpos,ypos
setmouse ,,1,1
Do
    Getmouse mx,my,,mb
    screencontrol 0,xpos,ypos
    If mb=1  Then
        
        If xpos=0 And ypos=0 Then
            'X shift
            If mx>maxX-30 And mx<>lastmx Then
                diffX=mx-lastmx
                Newxres+=diffX
                MoveWindow(Win,0,0,Newxres,Newyres,1)
                Setmouse ,,1,1
            End If
            'Y shift
            If my>maxY-30 And my<>lastmy Then
                diffY=mY-lastmY
                NewYres+=diffY
                MoveWindow(Win,0,0,Newxres,Newyres,1)
                Setmouse ,,1,1
            End If
        End If
    End If
    If Newxres>MonitorW Then Newxres=MonitorW
    If Newyres>MonitorH Then Newyres=MonitorH
    MaxX=Newxres
    MaxY=Newyres
    If mx<maxX-30 And my<maxY-30 Then
        If mx>0 And my>0 Then moveall:Setmouse,,1,1
    End If
    If mb=2 Then  MoveWindow(Win,0,0,Newxres,Newyres,1):Setmouse ,,1,1
    Screenlock
    Line(0,0)-(xres-1,yres-1),Rgb(0,0,255),b
    Screenunlock
    Sleep 10,1
    lastmx=mx
    lastmy=my
    printf(!"%s\r","Right click to reset, Resolutions = "+"    "+ "," + "    ")
    printf(!"%s\r","Right click to reset, Resolutions = "+Str(Newxres)+ "," + Str(Newyres))
Loop Until Len(Inkey)
Sleep
 

[dafhi]

dodicat i got some inspiration from your lines and polynomial interpolation

updated

[albert]

@Daphi

That's some bad ass rendering!!!

[dodicat]

Nice work Dafhi.