Squares

General FreeBASIC programming questions.
badidea
Posts: 1617
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Postby badidea » Nov 13, 2019 18:12

A 1000 abstract doodles before the year of the year must be possible.
Can I suggest animated doodles? Change 1 parameter with time?

Like this:

Code: Select all

const SCRN_W = 800, SCRN_H = 600
const as single PI = atn(1) * 4
const as single PI2 = PI * 2

type sgl2d
   as single x, y
end type

type sgl3d
   as single x, y, z
end type

union rgba_union
   value as ulong
   type
      b as ubyte
      g as ubyte
      r as ubyte
      a as ubyte
   end type
end union

'      z
'      |
'      |
'      |
'      +-------- y
'     /
'    /
'   x

sub pset3d(p3d as sgl3d, pixel as ulong)
   dim as sgl2d p2d
   p2d.x = (scrn_w \ 2) + (p3d.y - p3d.x / 4)
   p2d.y = (scrn_h \ 2) + (p3d.x / 2 - p3d.z)
   pset (p2d.x, p2d.y), pixel
end sub

sub dimScreen(dimFactor as single)
   dim as integer pitch, xi, yi
   dim as rgba_union ptr pRow
   ScreenInfo , , , , pitch
   dim as any ptr pPixels = ScreenPtr()
   if pPixels = 0 then exit sub
   for yi = 0 to SCRN_H - 1
      pRow = pPixels + yi * pitch
      for xi = 0 to SCRN_W - 1
         pRow[xi].r *= dimFactor
         pRow[xi].g *= dimFactor
         pRow[xi].b *= dimFactor
      next
   next
end sub

screenres SCRN_W, SCRN_H, 32

dim as sgl3d p1, p2
dim as single dx, dy, axy, ayz

while inkey <> chr(27)
   screenlock
   dimscreen(0.9)
   axy += PI2 / 500
   dx = cos(axy) * 200
   dy = sin(axy) * 200
   for ayz = 0 to PI2 step PI2 / 2000
      p1.y = cos(2*axy) * sin(ayz * 2) * 150 + dy
      p1.z = sin(axy) * cos(ayz) * 150
      p1.x = dx
      pset3d(p1, rgb(p1.x / 2 + 127, p1.z / 2 + 127, p1.y / 3 + 127))
      p2.x = -p1.x
      p2.y = -p1.y
      p2.z = p1.z
      pset3d(p2, rgb(-p1.x / 2 + 127, -p1.z / 2 + 127, -p1.y / 3 + 127))
   next
   screenunlock
   sleep 15
wend

sleep


Or this one that looks a bit disturbing:

Code: Select all

const SCRN_W = 800, SCRN_H = 600
const as single PI = atn(1) * 4
const as single PI2 = PI * 2

type sgl2d
   as single x, y
end type

type sgl3d
   as single x, y, z
end type

union rgba_union
   value as ulong
   type
      b as ubyte
      g as ubyte
      r as ubyte
      a as ubyte
   end type
end union

'      z
'      |
'      |
'      |
'      +-------- y
'     /
'    /
'   x

sub pset3d(p3d as sgl3d, pixel as ulong)
   dim as sgl2d p2d
   p2d.x = (scrn_w \ 2) + (p3d.y - p3d.x / 4)
   p2d.y = (scrn_h \ 2) + (p3d.x / 2 - p3d.z)
   pset (p2d.x, p2d.y), pixel
end sub

sub dimScreen(dimFactor as single)
   dim as integer pitch, xi, yi
   dim as rgba_union ptr pRow
   ScreenInfo , , , , pitch
   dim as any ptr pPixels = ScreenPtr()
   if pPixels = 0 then exit sub
   for yi = 0 to SCRN_H - 1
      pRow = pPixels + yi * pitch
      for xi = 0 to SCRN_W - 1
         pRow[xi].r *= dimFactor
         pRow[xi].g *= dimFactor
         pRow[xi].b *= dimFactor
      next
   next
end sub

sub rotate(p3d as sgl3d, xTheta as single, yTheta as single, zTheta as single)
   dim as single x = p3d.x, y = p3d.y, z = p3d.z
   dim as single xNew, yNew, zNew
   yNew = y * cos(xTheta) - z * sin(xTheta)
   zNew = z * cos(xTheta) + y * sin(xTheta)
   y = yNew
   z = zNew
   zNew = z * cos(yTheta) - x * sin(yTheta)
   xNew = x * cos(yTheta) + z * sin(yTheta)
   x = xNew
   xNew = x * cos(zTheta) - y * sin(zTheta)
   yNew = y * cos(zTheta) + x * sin(zTheta)
   p3d.x = xNew
   p3d.y = yNew
   p3d.z = zNew
end sub

screenres SCRN_W, SCRN_H, 32

dim as sgl3d p1, p2, p3, p4
dim as single dx, dy, axy, ayz
dim as ulong colour

while inkey <> chr(27)
   screenlock
   dimscreen(0.90)
   axy += PI2 / 1000
   dx = cos(axy/5) * 150
   dy = sin(axy/4) * 150
   for ayz = 0 to PI2 step PI2 / 2000
      p1.y = sin(ayz * 2) * 100 + dy
      p1.z = cos(axy + ayz) * 100
      p1.x = dx
      rotate(p1, sin(axy), -ayz, cos(axy) * ayz)
      colour = rgb(p1.x / 2 + 127, p1.z / 2 + 127, p1.y / 3 + 127)
      pset3d(p1, colour)
      p2 = p1
      p3 = p1
      p4 = p1
      p2.x = -p1.x
      p3.z = -p1.z
      p4.x = -p1.x
      p4.z = -p1.z
      pset3d(p2, colour)
      pset3d(p3, colour)
      pset3d(p4, colour)
   next
   screenunlock
   sleep 15
wend

sleep
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 14, 2019 18:48

@Dodicat

I think i got a compression formula that works... I started on the de-compressor...

v1 = 2 bit input

if v1 = 0 then outs1+="0"
if v1 = 1 then outs1+="1"
if v1 = 2 then outs1+="100"
if v1 = 3 then outs1+="101"

Seems to work..

Here's the "Test Bed" , where i try to write the de-compressor..

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    'print string(99,"=")
    'print "inp = " ; (s)
    'print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr ulp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *ulp ) : ulp+= 1
        n1 = right( n1 , 8 )
    .   bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as longint v1
    for a as longint = 1 to len( bits ) step 2
       
        v1 = val( "&B" + mid( bits , a , 2 ) )
       
        if v1 = 0 then outs1+="0"
        if v1 = 1 then outs1+="1"
        if v1 = 2 then outs1+="100"
        if v1 = 3 then outs1+="101"
       
        'print v1
        'print outs1
        'print outs2
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len(outs1)  , outs1
   
    dim as ubyte count = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( outs1 ) / 8 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs1+= "0" : count+=1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    final = chr( count ) + final
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as ubyte count = asc( left( chrs , 1 ) )
    chrs = mid( chrs , 2 )
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr ulp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *ulp ) : ulp+= 1
        n1 = right( n1 , 8 )
    .   bits+= n1
    next
   
    bits = left( bits , len( bits ) - count )
   
    print "d bin = " ; len(bits) , bits

    dim as string _0 = string( len( bits ) , "-" )
    dim as string _1 = string( len( bits ) , "-" )
    dim as string _100 = string( len( bits ) , "-" )
    dim as string _101 = string( len( bits ) , "-" )
   
    dim as longint place
   
    place = 0
    do
        place = instr( place+1 , bits , "100" )
        if place > 0 then
            mid( bits , place , 3 ) = "---"
            mid( _100 , place , 3 ) = "100"
        end if
    loop until place = 0

    place = 0
    do
        place = instr( place+1 , bits , "101" )
        if place > 0 then
            mid( bits , place , 3 ) = "---"
            mid( _101 , place , 3 ) = "101"
        end if
    loop until place = 0

    print "d bin = " ; len(bits) , bits
    print "d bin = " ; len(_100) , _100
    print "d bin = " ; len(_101) , _101
   
    return chrs
   
end function

albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 14, 2019 18:51

@badidea

Thanks for the animations...
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 15, 2019 2:41

@Dodicat

My above compressor , doesn't work...

0
1
100
101

Sometimes the 0's and 1's make 100 and 101... Not very often , but enough to make decompression impossible..
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 16, 2019 1:44

@Dodicat

I think i can decompress this one...

dim as string outs1 = ""
for a as longint = 1 to len( bits ) step 3

n1 = mid( bits , a , 3 )

if n1 = "000" then outs1+= "00"
if n1 = "001" then outs1+= "01"

if n1 = "010" then outs1+= "010"
if n1 = "011" then outs1+= "011"

if n1 = "100" then outs1+= "100"
if n1 = "101" then outs1+= "101"

if n1 = "110" then outs1+= "110"
if n1 = "111" then outs1+= "111"

next

You can change the input size on line 103

Compresses any size down to triple digits after 100 loops.

Code: Select all


Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string


Namespace Zlibrary

#inclib "zlib"
Extern "C"
    Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
    Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
    Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
    Dim As String var1,var2
    Dim As Integer pst
    #macro splice(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
        var1=Mid(stri,1,pst-1)
        var2=Mid(stri,pst+1)
    Else
        var1=stri
    End If
    #endmacro
    splice(text,"|",var1,var2)
    text=var2
    passed_length=Valint(var1)
    Return text
End Function


'=================   UNPACK ===============
Function unpack(file As String) As String
    Dim As Integer passed_length
    Dim As String text=getpassedinfo(file,passed_length)
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength =passed_length
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=uncompress(destination,@destinationlength, source, stringlength)
    If mistake<>0 Then Print "There was an error":Sleep:End
    Dim As String uncompressed
    uncompressed=String(destinationlength,0)
    For i As Integer = 0 To destinationlength- 1
        uncompressed[i]=(destination[i])
    Next
    Deallocate destination
    Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
    Dim As String text=file
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength = compressBound(stringlength)
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=compress(destination, @destinationlength, source, stringlength)
    If mistake <>0 Then Print "There was an error"
    Dim As String compressed
    compressed=String(destinationlength,0)
    For n As Integer=0 To destinationlength-1
        compressed[n]=destination[n]
    Next n
    compressed=stringlength &"|"+compressed
    Deallocate destination
    Return compressed
End Function

End Namespace


'==================================================================
'==================================================================
'test zipper
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible
       
        s = compress_loop(s)
       
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
   
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
   
    Print "packed string "
    Print Len(compressed)
    Print
   
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
   
    'sleep 1000
   
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
   
    print "press a key for next compression." ; " loops = " ; loops ; " out of 100."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 100

print "Press a key to decompress."
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
    s = Zlibrary.unpack(comp)
    outs = decompress_loop(s)
    comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'============================,===================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    dim as ubyte count1 = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( bits ) / 3 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then bits+= "0" : count1+= 1
    loop until dec1 = 0
   
    print "c bin = " ; len(bits) ' , bits
   
   
    dim as string outs1 = ""
    for a as longint = 1 to len( bits ) step 3
       
        n1 = mid( bits , a , 3 )
       
        if n1 = "000" then outs1+= "00"
        if n1 = "001" then outs1+= "01"
       
        if n1 = "010" then outs1+= "010"
        if n1 = "011" then outs1+= "011"
       
        if n1 = "100" then outs1+= "100"
        if n1 = "101" then outs1+= "101"
       
        if n1 = "110" then outs1+= "110"
        if n1 = "111" then outs1+= "111"
       
    next

    print "c out = " ; len(outs1) ' , outs1
   
    dim as ubyte count2 = 0
    do
        str1 = str( len( outs1 ) / 8 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs1+= "0" : count2+= 1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    final = chr( count1 ) + chr( count2 ) + final
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as ubyte count1 = asc( left( chrs , 1 ) )
    chrs = mid( chrs , 2 )
    dim as ubyte count2 = asc( left( chrs , 1 ) )
    chrs = mid( chrs , 2 )
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    bits = left( bits , len( bits ) - count2 )
   
    print "d bin = " ; len(bits) ' , bits

    return chrs
   
end function

albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 16, 2019 4:17

@badidea

I've done several hundred animated doodles.. Haven't done any in the last few years though.

Here's one , Me and Dodicat wrote together.. "Sea-Creature_3D"

Code: Select all

'rotate-include
Dim Shared np(1 To 6) As Double
         
Sub rotate2d(Byval pivot_x As Double,_   'turns about this point
           Byval pivot_y As Double,_
           Byval first_x As Double,_    'centre for circles
           Byval first_y As Double,_
           Byval second_x As Double, _   'radius for circles
           Byval second_y As Double, _   'aspect
           Byval arc_1 As Double,_       'arcs only for circle, 0 for lines
           Byval arc_2 As Double,_
           Byval angle As Double, _      'all below for circles and lines
           Byval magnifier As Double,_
           Byval dilator As Double,_
           Byval colour As Integer,_
           Byval thickness As Double,_
           Byref shape As String,_
           image As Any Pointer=0)
           'rotated line is  (np(1),np(2))-(np(3),np(4))
           'rotated circle centre is np(3),np(4)
           'shape:
           'line - draws the line
           'linepoint - does the calculation, draws nothing
           'linepointset - does the calculations, sets a pixel at the line ends
           'ALSO circle,circlepoint, circlepointset,box, boxfill, circlefill.
           'arcs from horizontal positive x axis in DEGREES
           'arc1<arc2 always e.g from 330 to 430
  shape=Lcase(shape)     
Dim p As Double = 4*Atn(1)  '(pi)
Dim radians As Double
Dim line_xvector As Double
Dim line_yvector As Double
Dim pivot_xvector As Double
Dim pivot_yvector As Double
Dim th As Double
  th=thickness
  Dim sx As Double=second_x
  'angle=angle mod 360
  If angle>=360 Then angle=0
radians=(2*p/360)*angle      'change from degrees to radians
#Macro thickline(t)
Dim As Double s,h,c
Dim As Uinteger prime=rgb(255,255,255)
h=Sqr(((np(1))-(np(3)))^2+((np(2))-(np(4)))^2)
s=((np(4))-np(2))/h
c=(np(1)-(np(3)))/h
Line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),prime
Line image, (np(3)-s*t/2,np(4)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(3)-s*t/2,np(4)-c*t/2),prime
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Paint image,((np(3)+np(1))/2, (np(4)+np(2))/2),prime,prime

Line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),colour
Line image, (np(3)-s*t/2,np(4)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Line image, (np(3)+s*t/2,np(4)+c*t/2)-(np(3)-s*t/2,np(4)-c*t/2),colour
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Paint image,((np(3)+np(1))/2, (np(4)+np(2))/2), colour, colour
#EndMacro

#macro thickcircle(t)
Dim As Uinteger prime=rgb(255,255,255)
Dim As Double xp1,xp2,yp1,yp2
Dim arc1 As Double=arc_1*p/180
Dim arc2 As Double=arc_2*p/180
arc1=2*p+(arc1-(radians))
arc2=2*p+(arc2-(radians))
sx=sx*magnifier
If arc1=arc2 Then
     Circle image,(np(3),np(4)),sx+t/2,prime,,,second_y
    Circle image,(np(3),np(4)),sx-t/2,prime,,,second_y
    Paint image,(np(3),np(4)+sx),prime,prime
    Paint image,(np(3)+sx,np(4)),prime,prime
    Circle image,(np(3),np(4)),sx+t/2,colour,,,second_y
    Circle image,(np(3),np(4)),sx-t/2,colour,,,second_y
    Paint image,(np(3),np(4)+sx),colour,colour
    Paint image,(np(3)+sx,np(4)),colour,colour
End If
if arc1<>arc2 Then
    xp1=np(3)+(sx)*Cos(.5*(arc2+arc1))
yp1=np(4)-(sx)*Sin(.5*(arc2+arc1))
Circle image,(np(3),np(4)),sx+t/2,prime,arc1,arc2,second_y
    Circle image,(np(3),np(4)),sx-t/2,prime,arc1,arc2,second_y
    Line image,(np(3)+(sx+t/2)*Cos(arc1),np(4)-(sx+t/2)*Sin(arc1))-(np(3)+(sx-t/2)*Cos(arc1),np(4)-(sx-t/2)*Sin(arc1)),prime
    Line image,(np(3)+(sx+t/2)*Cos(arc2),np(4)-(sx+t/2)*Sin(arc2))-(np(3)+(sx-t/2)*Cos(arc2),np(4)-(sx-t/2)*Sin(arc2)),prime

    Paint image,(xp1,yp1),prime,prime
   
Circle image,(np(3),np(4)),sx+t/2,colour,arc1,arc2,second_y
    Circle image,(np(3),np(4)),sx-t/2,colour,arc1,arc2,second_y
    Line image,(np(3)+(sx+t/2)*Cos(arc1),np(4)-(sx+t/2)*Sin(arc1))-(np(3)+(sx-t/2)*Cos(arc1),np(4)-(sx-t/2)*Sin(arc1)),colour
    Line image,(np(3)+(sx+t/2)*Cos(arc2),np(4)-(sx+t/2)*Sin(arc2))-(np(3)+(sx-t/2)*Cos(arc2),np(4)-(sx-t/2)*Sin(arc2)),colour

    Paint image,(xp1,yp1),colour,colour
   
End If
#endmacro

magnifier=dilator*magnifier     
pivot_xvector=first_x-pivot_x
pivot_yvector=first_y-pivot_y
pivot_xvector=dilator*pivot_xvector 
pivot_yvector=dilator*pivot_yvector
Dim mover(1 To 2,1 To 2) As Double
Dim new_pos(1 To 2) As Double
mover(1,1)=Cos(radians)
mover(2,2)=Cos(radians)
mover(1,2)=-Sin(radians)
mover(2,1)=Sin(radians)

line_xvector=magnifier*(second_x-first_x)                   'get the vector
line_yvector=magnifier*(second_y-first_y)                   'get the vector

new_pos(1)=mover(1,1)*pivot_xvector+mover(1,2)*pivot_yvector +pivot_x
new_pos(2)=mover(2,1)*pivot_xvector+mover(2,2)*pivot_yvector +pivot_y
Dim new_one(1 To 2) As Double            'To hold the turned value

new_one(1)=mover(1,1)*line_xvector+mover(1,2)*line_yvector +first_x
new_one(2)=mover(2,1)*line_xvector+mover(2,2)*line_yvector +first_y
Dim xx As Double   'translation
Dim yy As Double
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
np(1)=new_one(1)-xx 
  np(2)=new_one(2)-yy   
  np(3)=first_x-xx
 np(4)=first_y-yy
Select Case shape
Case "line"
    If th<2 Then
 Line image,(np(3),np(4))-(np(1),np(2)),colour
Else
 thickline(th)   
 End If
Case "circle"
    Dim arc1 As Double=arc_1*p/180
Dim arc2 As Double=arc_2*p/180
    If arc1=arc2 Then
    If th<=3 Then
        For n As Double=magnifier*sx-1 To magnifier*sx+1 Step .5
     Circle image,(np(3),np(4)),n,colour,,,second_y       
 'circle image,(np(3),np(4)),magnifier*sx,colour,,,second_y
 Next n
Else
 thickcircle(th)
End If
Endif
If arc1<>arc2 Then
If th<=3 Then
    arc1=2*p+(arc1-(radians))'new
arc2=2*p+(arc2-(radians))'new
    For n As Double=magnifier*sx-1 To magnifier*sx+1 Step .5
     Circle image,(np(3),np(4)),n,colour,arc1,arc2,second_y   
   ' circle image,(np(3),np(4)),magnifier*sx,colour,arc1,arc2,second_y
    Next n
Else
    thickcircle(th)
End If
End If
Case "circlefill"
    Dim As Double xp1,xp2,yp1,yp2
Dim As Uinteger prime=rgb(255,255,255)
Dim arc1 As Double=arc_1*p/180
Dim arc2 As Double=arc_2*p/180
If arc1=arc2 Then Circle image,(np(3),np(4)),magnifier*sx,colour,,,second_y,F
If arc1<>arc2 Then

 xp1=np(3)+magnifier*sx*Cos(.5*(arc2+arc1))*3/4
yp1=np(4)-magnifier*sx*Sin(.5*(arc2+arc1))*3/4   
Circle image,(np(3),np(4)),magnifier*sx,prime,arc1,arc2,second_y
Line image,(np(3),np(4))-(np(3)+magnifier*sx*Cos(arc2),np(4)-magnifier*sx*Sin(arc2)),prime
Line image,(np(3),np(4))-(np(3)+magnifier*sx*Cos(arc1),np(4)-magnifier*sx*Sin(arc1)),prime
Paint image,(xp1,yp1),prime,prime

Circle image,(np(3),np(4)),magnifier*sx,colour,arc1,arc2,second_y
Line image,(np(3),np(4))-(np(3)+magnifier*sx*Cos(arc2),np(4)-magnifier*sx*Sin(arc2)),colour
Line image,(np(3),np(4))-(np(3)+magnifier*sx*Cos(arc1),np(4)-magnifier*sx*Sin(arc1)),colour
Paint image,(xp1,yp1),colour,colour
End If
 Case"box"
 Line image,(np(3),np(4))-(np(1),np(2)),colour,b
Case "boxfill"
 Line image,(np(3),np(4))-(np(1),np(2)),colour,bf
        Case "linepoint","circlepoint"
  'nothing drawn
Case "linepointset","circlepointset"
 If shape="linepointset" Then
 Pset image,(np(1),np(2)),colour
 Pset image,(np(3),np(4)),colour
 Endif
 If shape="circlepointset" Then
     Pset image,(np(3),np(4)),colour
 End If

        Case Else
 Print "unknown rotation shape"
End Select
End Sub


Sub mv(m1() As Double,m2() As Double,ans() As Double) 'MATRIX x VECTOR
   Dim s As Double
    For i As Integer=1 To 3
        s=0
        For k As Integer = 1 To 3
            s=s+m1(i,k)*m2(k)
        Next k
        ans(i)=s
        Next i
    End Sub

 Sub rotate3d(Byval pivot_x As Double,_  'x pivot for rotation
                   Byval pivot_y As Double,_  'y pivot for rotation
                   Byval pivot_z As Double,_  'z pivot for rotation
                   Byval first_x As Double,_  'x for line,or centre for circle
                   Byval first_y As Double,_  'y for line,or centre for circle
                   Byval first_z As Double,_  'z for line or circle
                   Byval second_x As Double, _'x for line,or radius for circle
                   Byval second_y As Double, _'y for line,or aspect for circle
                   Byval second_z As Double,_ 'z for line, first arc position circle
                   Byval second_arc As Double,_ 'second arc position circle,0 line
                   Byval angleX As Double, _   'angle to rotate round x axis
                   Byval angleY As Double,_    'angle to rotate round y axis
                   Byval angleZ As Double,_    'angle to rotate round z axis
                   Byval magnifier As Double,_ '1=no magnifacation
                   Byval dilator As Double,_   'times distance from pivot(1=no dilation)
                   Byval colour As Integer,_   'color for line or circle
                   Byval thickness As Double,_ 'thickness line or circle
                   Byref shape As String,_ 'line/circle/circlefill/box/boxfill/linepoint[set],circlepoint[set]"
                   Byref mode As String,_    '2d or 3d
                   Byval perspective As Double=0,_ 'add some 3d perspective 0 to 1 approx
                   image As Any Pointer=0)        'write to an image if required
  shape=Lcase(shape)
  mode=Lcase(mode)
  Dim th As Double
  th=thickness
  Dim As Double zval,pp   'used in get_perspective
  Dim sx As Double=second_x
Dim p As Double = 4*Atn(1)  '(pi)
Dim angleX_degrees As Double
Dim angleY_degrees As Double
Dim angleZ_degrees As Double

#Macro thickline(t)
Dim As Double s,h,c
Dim As Uinteger prime=rgb(255,255,255)
h=Sqr(((np(1))-(np(4)))^2+((np(2))-(np(5)))^2)
s=((np(5))-np(2))/h
c=(np(1)-(np(4)))/h
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),prime
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),prime
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2),prime,prime

Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),colour
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),colour
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2), colour, colour
#EndMacro

#macro thickcircle(t)
Dim As Uinteger prime=rgb(255,255,255)
Dim As Double xp1,xp2,yp1,yp2
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
arc1=2*p+(arc1-(anglez_degrees))
arc2=2*p+(arc2-(anglez_degrees))
sx=sx*magnifier
If arc1=arc2 Then
     Circle image,(np(4),np(5)),sx,prime,,,second_y
    Circle image,(np(4),np(5)),sx-t,prime,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),prime,prime
    Paint image,(np(4)+sx-t/2,np(5)),prime,prime
    Circle image,(np(4),np(5)),sx,colour,,,second_y
    Circle image,(np(4),np(5)),sx-t,colour,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),colour,colour
    Paint image,(np(4)+sx-t/2,np(5)),colour,colour
End If
if arc1<>arc2 Then
    xp1=np(4)+(sx-t/2)*Cos(.5*(arc2+arc1))
yp1=np(5)-(sx-t/2)*Sin(.5*(arc2+arc1))
Circle image,(np(4),np(5)),sx,prime,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,prime,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),prime
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),prime
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),prime,prime

   Circle image,(np(4),np(5)),sx,colour,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,colour,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),colour
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),colour
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),colour,colour
End If
#endmacro

#macro get_perspective(np3,np6)
For n As Integer=3 To 6 Step 3
zval =np(n)  'for perspective
pp=perspective*((zval+1000)/1000-1)
pp=(1-pp)
If n=3 Then
np(n-2)=np(n-2)-pivot_x
np(n-1)=np(n-1)-pivot_y
np(n-2)=np(n-2)*pp
np(n-1)=np(n-1)*pp
np(n-2)=np(n-2)+pivot_x
np(n-1)=np(n-1)+pivot_y
Endif
If n=6 Then
    np(n-2)=np(n-2)-pivot_x
    np(n-1)=np(n-1)-pivot_y
    np(n-2)=np(n-2)*pp
    np(n-1)=np(n-1)*pp
    np(n-2)=np(n-2)+pivot_x
    np(n-1)=np(n-1)+pivot_y
Endif
Next n
sx=(pp)*sx
#endmacro

Dim pivot_vector(1 To 3) As Double
Dim line_vector(1 To 3) As Double
magnifier=dilator*magnifier
If shape="circle" Then
angleX=angleX Mod 360:angleY=angleY Mod 360:angleZ=angleZ Mod 360
End If
angleX_degrees=(2*p/360)*angleX     
angleY_degrees=(2*p/360)*angleY
angleZ_degrees=(2*p/360)*angleZ
pivot_vector(1)=first_x-pivot_x
pivot_vector(2)=first_y-pivot_y
pivot_vector(3)=first_z-pivot_z
pivot_vector(1)=dilator*pivot_vector(1)
pivot_vector(2)=dilator*pivot_vector(2)
pivot_vector(3)=dilator*pivot_vector(3)

Dim Rx(1 To 3,1 To 3) As Double
Dim Ry(1 To 3,1 To 3) As Double
Dim Rz(1 To 3,1 To 3) As Double
'rotat1on matrices about the three axix
If mode="3d" Then
Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
Rx(2,1)=0:Rx(2,2)=Cos(angleX_degrees):Rx(2,3)=-Sin(angleX_degrees)
Rx(3,1)=0:Rx(3,2)=Sin(angleX_degrees):Rx(3,3)=Cos(angleX_degrees)

Ry(1,1)=Cos(angleY_degrees):Ry(1,2)=0:Ry(1,3)=Sin(angleY_degrees)
Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
Ry(3,1)=-Sin(angleY_degrees):Ry(3,2)=0:Ry(3,3)=Cos(angleY_degrees)
Endif

Rz(1,1)=Cos(angleZ_degrees):Rz(1,2)=-Sin(angleZ_degrees):Rz(1,3)=0
Rz(2,1)=Sin(angleZ_degrees):Rz(2,2)=Cos(angleZ_degrees):Rz(2,3)=0
Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1

line_vector(1)=magnifier*(second_x-first_x)'*pp                   'get the vector
line_vector(2)=magnifier*(second_y-first_y)'*pp                   'get the vector
line_vector(3)=magnifier*(second_z-first_z)'*pp

Dim new_pos(1 To 3) As Double
Dim temp1(1 To 3) As Double
Dim temp2(1 To 3) As Double
If mode="3d" Then
mv Rx(),pivot_vector(),temp1()           
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_pos()
Endif
If mode="2d" Then
    mv Rz(),pivot_vector(),new_pos()
    Endif
new_pos(1)=new_pos(1)+pivot_x
new_pos(2)=new_pos(2)+pivot_y
new_pos(3)=new_pos(3)+pivot_z


Dim new_one(1 To 3) As Double            'To hold the turned value
If mode="3d" Then
mv Rx(),line_vector(),temp1()              'rotate
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_one()
Endif
If mode="2d" Then
    mv Rz(),line_vector(),new_one()
    Endif
new_one(1)=new_one(1)+first_x              'translate
new_one(2)=new_one(2)+first_y
new_one(3)=new_one(3)+first_z

Dim xx As Double   
Dim yy As Double
Dim zz As Double
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
zz=first_z-new_pos(3)
 np(1)=new_one(1)-xx 
 np(2)=new_one(2)-yy
 np(3)=new_one(3)-zz
 np(4)=first_x-xx
 np(5)=first_y-yy
 np(6)= first_z-zz
If perspective <> 0 Then
get_perspective(np(3),np(6))
End If
Select Case shape
Case "line"
    If th<2 Then
 Line image,(np(4),np(5))-(np(1),np(2)),colour
Else
 thickline(th)   
 End If
Case "circle"
    Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
    If arc1=arc2 Then
    If th<=2 Then
 Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y
Else
 thickcircle(th)
End If
Endif
If arc1<>arc2 Then
If th<=2 Then
    Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Else
    thickcircle(th)
End If
End If
Case "circlefill"
    Dim As Double xp1,xp2,yp1,yp2
Dim As Uinteger prime=rgb(255,255,255)
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
If arc1=arc2 Then Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y,F
If arc1<>arc2 Then
 xp1=np(4)+magnifier*sx*Cos(.5*(arc2+arc1))*3/4
yp1=np(5)-magnifier*sx*Sin(.5*(arc2+arc1))*3/4   
Circle image,(np(4),np(5)),magnifier*sx,prime,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),prime
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),prime
Paint image,(xp1,yp1),prime,prime

Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),colour
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),colour
Paint image,(xp1,yp1),colour,colour
End If
 Case"box"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,b
Case "boxfill"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,bf
        Case "linepoint","circlepoint"
  'nothing drawn
Case "linepointset","circlepointset"
 If shape="linepointset" Then
 Pset image,(np(1),np(2)),colour
 Pset image,(np(4),np(5)),colour
 Endif
 If shape="circlepointset" Then
     Pset image,(np(4),np(5)),colour
 End If

        Case Else
 Print "unknown rotation shape"
End Select
End Sub
'END OF ROTATOR

'End of Dodicats rotate include
'begin code segment
'==========================================================
'==========================================================
'==========================================================
'   --Sea Creature--
'by Albert Redditt 5/12-16/2010
'Written in FreeBasic for Windows
' 3D rotations code by Dodicat from Scottland.
'==========================================================
'==========================================================
'==========================================================
Declare Sub make_background()
dim as double x1, y1, x2, y2, deg, span, radians
dim as integer xctr, yctr, radius, divisions, fullcircle
dim as integer span_toggle, x_position_toggle , y_position_toggle, perspective_toggle

Dim Shared im As Any Pointer

Dim As Integer x,y
screeninfo(x,y)
'screenres x,y,32,1,FB.GFX_ALPHA_PRIMITIVES Or FB.GFX_FULLSCREEN'FB.GFX_FULLSCREEN
screenres 1024,768,32

im= imagecreate (x,y,rgb(0,0,0))

xctr = .3*x
yctr = .5*y'300+100
radius = .1*x'290
divisions = 45
span = 1

span_toggle = 0
x_position_toggle = 0
y_position_toggle = 0
perspective_toggle = 0

Dim deg2 As Double
Dim p As Double=0  '(PERSPECTIVE)
make_background
do
    screenlock
    Cls
    Put(0,0),im,Pset
    radians = Atn(1) / divisions
    fullcircle = Atn(1)*8 / radians

    For deg = 0 To fullcircle Step 1
    deg2=deg
   
        y1 = radius * cos(deg*radians)
        x1 = radius * sin(deg*radians)
   
        'old sea-creature formulas
        'y2 = radius * cos(deg*span*radians*radians)*sin(span*radians*2)
        'x2 = radius * sin(deg*span*radians*radians)*cos(span*radians/3)
       
        'new sea-creature formulas mor active
        y2 = radius * cos(deg*span*radians*radians*sin(span*radians))
        x2 = radius * sin(deg*span*radians*radians*cos(span*radians))
       
        'line(xctr,yctr)-(xctr+x1,yctr+y2),15
        'line(xctr+x1,yctr+y2)-(xctr+x2,yctr+y1),9
        'circle(xctr+x1,yctr+y2),5,11,,,,f
        'circle(xctr+x2,yctr+y1),5,11,,,,f
    rotate3d(xctr,yctr,100,xctr+x1,yctr+y2,250,xctr+x2,yctr+y1,250,.0,deg2,deg2,deg2,1,1,rgba(255,85,255,deg/2),1,"line","3d",p)     
        'Line(xctr+x1,yctr+y2)-(xctr+x2,yctr+y1),9
    rotate3d(xctr,yctr,100,xctr+x2,yctr+y1,250,5,0,.0,.0,deg2,deg2,deg2,1,1,rgba(85,255,255,deg/2),1,"circlefill","3d",p)     
        'Circle(xctr+x2,yctr+y1),5,11,,,,f
    rotate3d(xctr,yctr,100,xctr+x1,yctr+y2,250,5,0,.0,.0,deg2,deg2,deg2,1,1,rgba(85,255,255,deg/2),1,"circlefill","3d",p)         
       
    next

    screenunlock
    sleep(20)
   
    select case span_toggle
        case 0
            span += 1
            if span >= 360 then span_toggle = 1
            cls
        case 1
            span -= 1
            if span <=-360 then span_toggle = 0
            cls
    end select
   
    select case x_position_toggle
        case 0
            xctr += .005*x
            if xctr >= 800 then x_position_toggle = 1
        case 1
            xctr -= .005*x
            if xctr <= 10  then x_position_toggle = 0
    end select
   
    select case y_position_toggle
        case 0
            yctr += .005*y
            if yctr >= 650 then y_position_toggle = 1
        case 1
            yctr -= .005*y
            if yctr <= 100 then y_position_toggle = 0

    end select
   
    select case perspective_toggle
        case 0
            p+=.2
            if p >= 4 then perspective_toggle = 1
        case 1
            p-=.2
            if p <= -4 then perspective_toggle = 0
    end select
   
loop until inkey <> ""

END ' end program


'=============================================
'=============================================
' make background subroutine
'=============================================
'=============================================
Sub make_background()
    Dim As Double xpiv,ypiv,zpiv,scx,scy,scz,dist,ax,ay,az,p,a,b
    Dim As Uinteger cl
    Dim pi As Double=4*Atn(1)
    Dim st As Double
    Dim As Integer f=1
    Dim As Double cnp(1 To 8),cznp(1 To 4),cz(1 To f,1 To f) 'copy line end positions
    Dim As Double cx,cy

  #macro edge(number)
    Select Case number
    'define two edges for cross product
        Case 1
            cnp(1)=np(1)
            cnp(2)=np(2)
            cnp(3)=np(4)
            cnp(4)=np(5)
            cznp(1)=np(3)
            cznp(2)=np(6)
        Case 2
            cnp(5)=np(1)
            cnp(6)=np(2)
            cnp(7)=np(4)
            cnp(8)=np(5)
            cznp(3)=np(3)
            cznp(4)=np(6)
   End Select
   'get the centroids
    cx=(cnp(1)+cnp(3)+cnp(5)+cnp(7))/4
    cy=(cnp(2)+cnp(4)+cnp(6)+cnp(8))/4
 #endmacro
 
 Dim As Double u1,u2,u3,v1,v2,v3,wx,wy,wz,nw
 #macro crossproduct(of_two_sides)
    'get vectors to origin
    u1=cnp(1)-cnp(3)
    u2=cnp(2)-cnp(4)
    u3=cznp(1)-cznp(2)
    v1=cnp(5)-cnp(7)
    v2=cnp(6)-cnp(8)
    v3=cznp(3)-cznp(4)
    'get the cross product
    wx=(u2*v3-v2*u3)
    wy=-(u1*v3-v1*u3)
    wz=(u1*v2-v1*u2)
    nw=Sqr(wx^2+wy^2+wz^2)
    'normalized cross product components
    wx=wx/nw
    wy=wy/nw
    wz=wz/nw
 #endmacro
 
 #macro surface(cl1,cl2) 
    Paint im,(cx,cy),cl1,cl2
 #endmacro
     
    xpiv=350
    ypiv=350
    zpiv=5000
    scx=500
    scy=350
    scz=0
    dist=3
    ax=0
    ay=12
    az=0
    p=0
    Dim As Integer red,green,blue
    st=2*Atn((dist/zpiv)*180/pi)
    Dim As Double min=2,max =-2
    Dim As Integer ck
    Dim As String action
    Dim As Uinteger lcl=rgb(0,1,0)
    ' do
   
    For b=-4 To 5 Step 1*st
        ax=b
        For a=-7 To 7 Step st
   
            ck=250*(wz+.999999955)/(.999999955-.99012835910 )
            cl=rgb(0,0+ck/2,40+ck)
            lcl=cl
            ay=a
            action="linepoint" 
            rotate3d(xpiv,ypiv,zpiv,scx-dist,scy-dist,scz,scx-dist,scy+dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)
            edge(1)
            rotate3d(xpiv,ypiv,zpiv,scx-dist,scy-dist,scz,scx+dist,scy-dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)
            edge(2)
            crossproduct(of_edges)
   
            action="line"
       
            rotate3d(xpiv,ypiv,zpiv,scx-dist,scy-dist,scz,scx-dist,scy+dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)
     
            rotate3d(xpiv,ypiv,zpiv,scx-dist,scy-dist,scz,scx+dist,scy-dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)

            rotate3d(xpiv,ypiv,zpiv,scx+dist,scy-dist,scz,scx+dist,scy+dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)
            rotate3d(xpiv,ypiv,zpiv,scx+dist,scy+dist,scz,scx-dist,scy+dist,scz,.0,ax,ay,az,1,1,lcl,1,action,"3d",p,im)
         
            surface(cl,lcl)
            If min>wz Then min=wz
            If max<wz Then max=wz

        Next a
    Next b
End Sub



Here's another one called "The-Temple" , Dodicat wrote the rotator code.

Code: Select all

 'Animated doodle "The Temple"
 
Type V3
    As Single x,y,z
    colour as uinteger
End Type
#define vct Type<V3>

Function Rotate3D(Fulcrum as V3,pt As v3,Angle As v3,scale As v3=Type<v3>(1,1,1)) As v3
    Dim As v3 p=vct(pt.x-Fulcrum.x,pt.y-Fulcrum.y,pt.z-Fulcrum.z)
    Dim As v3 rot,temp
    Dim As Single s=Sin(angle.x),c=Cos(angle.x)
    temp=vct((p.y)*C+(-p.z)*S,(p.z)*C+(p.y)*S)
    rot.y=temp.x
    s=Sin(angle.y):c=Cos(angle.y)
    temp=vct((temp.y)*C+(-p.x)*S,(p.x)*C+(temp.y)*S)
    rot.z=temp.x
    s=Sin(angle.z):c=Cos(angle.z)
    temp=vct((temp.y)*C+(-rot.y)*S,(rot.y)*C+(temp.y)*S)
    rot.x=temp.x:rot.y=temp.y
    Return vct((scale.x*rot.x+Fulcrum.x),(scale.y*rot.y+Fulcrum.y),(scale.z*rot.z+Fulcrum.z),pt.colour)
End Function

Function apply_perspective(p As V3,eyepoint As V3) As V3
    Dim As Single   w=1+(p.z/eyepoint.z)
    If w=0 Then w=1e-20
    Return Type<V3>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z,p.colour)
End Function
'====================== End of rotator and perspective getter ======================================

'extra subs to regulate speed
Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

'setup screen
dim as integer xres,yres
screeninfo xres,yres
screenres xres,yres,8,1,8

'trig variables setup
dim as single c1,c2
dim as single s1,s2
dim as single x1,x2
dim as single y1,y2
dim as single z1
dim as single deg1,deg2
dim as single rad = atn(1) / 45

dim as integer xctr
dim as integer yctr
dim as integer radius
dim as integer count

xctr   = xres/2
yctr   = yres/2
radius = 200
count  = 1
   
    'dim array to hold all the points
    redim as V3 array(0)
    for deg1 = 0 to 360 step 2
       
        c1=cos(deg1*rad)
        s1=sin(deg1*rad)
       
        for deg2 = 0 to 360 step 2
           
            c2 = cos(deg2*rad)
            s2 = sin(deg2*rad)
           
            x1=radius* (atan2( tan(c2+c2) , tan(c1+c1) ) /2 ) * atan2(deg2,tan(c2)) / 1.5
            y1=radius* (atan2( tan(s2+s2) , tan(s1+s1) ) /2 ) * atan2(deg2,tan(s2)) / 1.5
           
            z1=radius * cos(c1+s1) * 1.5
               
            redim preserve array(count)
            array(count)=vct(xctr+x1+x2, yctr+y1+y2 , yctr+z1, 9+count mod 2)
            count+=1
           
        next
       
    next
   
   
'rotate variables setup
dim as V3 centre   = vct(xctr,yctr,0500)
dim as V3 eyepoint = vct(xctr,yctr,1000)
dim as V3 angle

'run program loop
dim as integer fps
dim as string ink
dim as single rot_x=.02 'radians
dim as single rot_y=.02
dim as single rot_z=.02
do
   
    var sleepover=regulate(60,fps)
   
    ink=inkey
   
    if ink=chr(255)+"H" then rot_x-=.02
    if ink=chr(255)+"P" then rot_x+=.02
    if ink=chr(255)+"M" then rot_y-=.02
    if ink=chr(255)+"K" then rot_y+=.02
    if ink=chr(255)+"R" then rot_z-=.02
    if ink=chr(255)+"S" then rot_z+=.02
    if ink=chr(32) then
        rot_x=0 : angle.x=0
        rot_y=0 : angle.y=0
        rot_z=0 : angle.z=0
    end if
   
    if ink=chr(13) then
        rot_x=.02
        rot_y=.02
        rot_z=.02
    end if
   
    angle.x+=rot_x
    angle.y+=rot_y
    angle.z+=rot_z
   
    screenlock
    cls
   
    for n1 as integer = 1 to ubound(array)
        var temp=rotate3d(centre,array(n1),angle,vct(1,1,1))
        temp=apply_perspective(temp,eyepoint)
        pset(temp.x,temp.y), temp.colour
    next n1
   
    draw string(20,20),"Frames per second = " & fps
    screenunlock
   
    sleep sleepover,1
       
    if ink=chr(27) then exit do
   
loop

SLEEP
END

albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 17, 2019 4:06

@Dodicat

I've got another compression idea that compresses...

n1 = 8 bits

s1 = ""
if mid( n1 , 1 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 2 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 3 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 4 , 1 ) = "1" then s1+= "1" else s1+="0"

if mid( n1 , 5 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 6 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 7 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 8 , 1 ) = "1" then s1+= "1"

if len( s1 ) = 7 then s1 = "0" + s1

outs1+= s1

I left off the "else s1+="0" from the last bit , if the output is 7 bits it puts a "0" in front instead of the rear.
It allows the formula to compress.. 80+% after 50 loops.

Now it's just a matter of finding the front added "0"

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    'print string(99,"=")
    'print "inp = " ; (s)
    'print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as string s1
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        s1 = ""
        if mid( n1 , 1 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 2 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 3 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 4 , 1 ) = "1" then s1+= "1" else s1+="0"
       
        if mid( n1 , 5 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 6 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 7 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 8 , 1 ) = "1" then s1+= "1" 'else s1+="0"
       
        if len( s1 ) = 7 then  s1 = "0" + s1
       
        outs1+= s1
       
        'print n1 , s1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len(outs1) , outs1

    dim as string final = ""
    dim as string s , n
    for a as longint = 1 to len( outs1 ) step 8
        's = mid( outs1 , a , 4 )
        'n = ""
        'n+= right( "00" + bin( val( mid( s , 1 , 1 ) ) ) , 2 )
        'n+= right( "00" + bin( val( mid( s , 2 , 1 ) ) ) , 2 )
        'n+= right( "00" + bin( val( mid( s , 3 , 1 ) ) ) , 2 )
        'n+= right( "00" + bin( val( mid( s , 4 , 1 ) ) ) , 2 )
        'final+= chr( val( "&B" + n ) )
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "d bin = " ; len(bits)  , bits
   
    return chrs
   
end function

albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 17, 2019 18:47

@Dodicat

n1 = mid( bits , a , 8 )

s1 = ""
if mid( n1 , 1 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 2 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 3 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 4 , 1 ) = "1" then s1+= "1" else s1+="0"

if mid( n1 , 5 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 6 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 7 , 1 ) = "1" then s1+= "1" else s1+="0"
if mid( n1 , 8 , 1 ) = "1" then s1+= "1" else s1+="0"

'rotate if it ends in zero
if right( s1 , 1 ) = "0" then s1 = right( s1 , 1 ) + left( s1 , 7 )

outs1+= s1

If you rotate on a condition , it compresses..

I tried rotating every byte , and every other byte , it doesn't compress.
But rotating , if bits equal a certain value , it compresses.

Now : the problem is , how to tell if a byte is rotated or not??
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 17, 2019 23:38

@Dodicat

Here's a compression remake of the above.

This time , if the value of the byte mod 2 = 0 then it swaps the first and last bits.

Compresses 80+% , after 50 loops.

I guess you'd swap the bits , and then test , to see if it's mod 2 = 0 ??

Not sure if it can be decompressed..

It sometimes decompresses okay.. keep pressing a key till it comes out "OK"

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    'print string(99,"=")
    'print "inp = " ; (s)
    'print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as string s1
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        s1 = ""
        if mid( n1 , 1 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 2 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 3 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 4 , 1 ) = "1" then s1+= "1" else s1+="0"
       
        if mid( n1 , 5 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 6 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 7 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 8 , 1 ) = "1" then s1+= "1" else s1+="0"
       
        dim as string s2 = right( s1 , 1 ) + left( s1 , 1 ) 
       
        ' if value mod 2 = 0 then swap first and last bits.
        if val( "&B" + s1 )  mod 2 = 0 then mid( s1 , 1 , 1 ) = left( s2 , 1 )  : mid( s1 , 8 , 1 ) = right( s2 , 1 )
       
        outs1+= s1       
       
        'print n1 , s1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len(outs1) , outs1

    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "d bin = " ; len(bits) , bits
   
    dim as string final = ""
    for a as longint = 1 to len( bits ) step 8
        final+= chr( val( "&B" + mid( bits , a , 8 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function



Doing "Time Rhymes".. I figured out the "357" Magnum ... 3 , 50 , 7 = bee lifty heaven..

===================================================================================
It also works swapping the 7th and 8th bits.
I tried swapping other bits on mod 2 = 0 , but it only compresses , it you swap the right most bit , with another..

dim as string s2 = mid( s1 , 7 , 1 ) + mid( s1 , 8 , 1 )
if val( "&B" + s1 ) mod 2 = 0 then mid( s1 , 8 , 1 ) = left( s2 , 1 ) : mid( s1 , 7 , 1 ) = right( s2 , 1 )

So, i guess if the last two bits are 00 or 01 then you swap the last two bits ?? Not sure...

Here it is swapping the last two bits..

It also compresses with byte mod 3 = 0..

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    draw string( 0,10) , left(s,100)
    draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as string s1
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        s1 = ""
        if mid( n1 , 1 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 2 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 3 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 4 , 1 ) = "1" then s1+= "1" else s1+="0"
       
        if mid( n1 , 5 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 6 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 7 , 1 ) = "1" then s1+= "1" else s1+="0"
        if mid( n1 , 8 , 1 ) = "1" then s1+= "1" else s1+="0"
       
        dim as string s2 = mid( s1 , 8 , 1 ) + mid( s1 , 7 , 1 )
       
        ' if value mod 2 = 0 then swap first and last bits.
        if val( "&B" + s1 )  mod 2 = 0 then mid( s1 , 7 , 1 ) = left( s2 , 1 )  : mid( s1 , 8 , 1 ) = right( s2 , 1 )
       
        outs1+= s1       
       
        'print n1 , s1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len(outs1) , outs1

    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "d bin = " ; len(bits) , bits
   
    dim as string final = ""
    for a as longint = 1 to len( bits ) step 8
        final+= chr( val( "&B" + mid( bits , a , 8 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function

albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 18, 2019 23:29

I came up with a funny last name..

Mr. Horsin

it could be hor-sin
it could be hors-in

HA-HA !
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 19, 2019 2:40

With compression:

I tried all combinations of swapping bits around.. and inverting all the bits..

Swapping and inverting doesn't compress...

if you pick a bit out , ( say bit 4 ) , and set every 4th bit to 0 or 1 it will compress.
But if you make a map string of the 4th bit , it won't compress..

So far the only thing i can get to compress:
Is shorting a bit sequence by making some sets shorter than the input , or making one bit or byte equal another.
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 21, 2019 2:58

@Dodicat

I think I've got a working compressor

n1 = mid( bits , a , 2 )

if n1 = "00" then outs1+="1"
if n1 = "01" then outs1+="00"
if n1 = "10" then outs1+="01"
if n1 = "11" then outs1+="110"

It only compresses 10K 50% after 100 loops , and compresses 100K and 1 Meg 74% after 100 loops.

The only thing is ; it's real slow.. Can't figure out , how to speed it up..

Here's the "Test Bed" , where i try to write a de-compressor..

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 64 , "0" )
    dim as string n1
    dim as ulongint ptr usp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 64 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    for a as longint = 1 to len( bits ) step 2
           
            n1 = mid( bits , a , 2 )
           
            if n1 = "00" then outs1+="1"
            if n1 = "01" then outs1+="00"
            if n1 = "10" then outs1+="01"
            if n1 = "11" then outs1+="110"
           
    next
   
    print "c out = " ; len( outs1 ) , outs1
   
    dim as ubyte count
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( outs1 ) / 64 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs1+= "0" : count+= 1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 64
        final+= mklongint( valulng( "&B" + mid( outs1 , a , 64 ) ) )
    next
   
    final = chr( count) + final
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc( left( chrs ,1 ) )
    chrs = mid( chrs , 2 )
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 64 , "0" )
    dim as string n1
    dim as ulongint ptr usp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 64 )
        bits+= n1
    next
   
    bits = left( bits , len( bits ) - count )
   
    print "c bin = " ; len(bits) , bits
   
    return chrs
   
end function


albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 21, 2019 3:44

Never mind...

You can have a 1101 , could be a 1-1-01 or a 110 - 1

1101 happens often enough , to make it compress 50%.

Back to doodles , tomorrow...
Stonemonkey
Posts: 586
Joined: Jun 09, 2005 0:08

Re: Squares

Postby Stonemonkey » Nov 21, 2019 23:01

Hi Albert, compression is something I look at now and again but never had any luck. One thing I'm looking at at the moment works like this:
Imagine a circle with 0-255 so it wraps around, take 3 byte values from the data you want to compress and place them on the circle. Then look for the largest gap between those values (could also cross the 255/0 boundary), that gap will always be at least 86 so going between those points the other way it will be at most something like 170. So the first value requires a range of 256, the second value requires a range of 170 and the 3rd value lies somewhere in between and its range depends on the first 2 values. A further value with a range of 6 is required to put them back in order.
From a quick test it seems like in 50% of cases it will compress and in 50% it expands but in the cases where it compresses there are bigger savings than there are losses in the cases that it expands. Although I am quite willing to accept that I'm overlooking something like the way 3 random values are distributed when sorted in such a way and that it could be that the cases where it expands are far more common than my 50%
I'll look into it some more but I'm going to need a way to work with really really big numbers.
albert
Posts: 5312
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Nov 22, 2019 2:22

@Dodicat

I think I've got a compression technique...

Here's the "Test Bed" where i try to write a de-compressor

The code is self explanatory.. See compress_loop()

Code: Select all


Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as ulongint  v1 , v2
    for a as longint = 1 to len( bits ) step 3
           
            v1 = val( "&B" + mid( bits , a , 3 ) )
           
            if v1 > 1 then
                n1 = "1"
                v2 = 0
                do
                    v2+= 2
                    n1+="0"
                loop until ( v2 = v1 ) or ( v2 + 1 = v1 )
               
                if v2 + 1 = v1 then n1 = "1" + n1
                v2 = 0
            else
                if v1 = 0 then n1="1"
                if v1 = 1 then n1="101"
            end if
           
            outs1+= n1
           
            'print v1 , v2 , n1 , outs1
            'sleep
            'if inkey = " " then end
           
    next

    print "c out = " ; len( outs1 ) , outs1
   
    dim as ubyte count = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( outs1 ) / 8 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs1+= "0" : count+= 1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next
   
    final = chr( count ) + final
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc( left( chrs ,1 ) )
    chrs = mid( chrs , 2 )
   
    print "d inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    bits = left( bits , len( bits ) - count )
   
    print "d bin = " ; len(bits) , bits
   
    return chrs
   
end function





@Stonemonkey

I've thought of using sines and cosines to compress , but have never actually worked on it..

I thought ; maybe you could create a sine formula , that would hit all the 1's in the data stream..
Maybe the formula would only be a few kilobytes?
Maybe you could have several built in formulas , that hit certain bits.. and just refer to the formulas by number..

Return to “General”

Who is online

Users browsing this forum: Majestic-12 [Bot] and 1 guest